diff -Nrc3pad gcc-3.2.3/gcc/ada/1aexcept.adb gcc-3.3/gcc/ada/1aexcept.adb *** gcc-3.2.3/gcc/ada/1aexcept.adb 2002-05-04 03:27:12.000000000 +0000 --- gcc-3.3/gcc/ada/1aexcept.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/1aexcept.ads gcc-3.3/gcc/ada/1aexcept.ads *** gcc-3.2.3/gcc/ada/1aexcept.ads 2002-05-04 03:27:12.000000000 +0000 --- gcc-3.3/gcc/ada/1aexcept.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/1ic.ads gcc-3.3/gcc/ada/1ic.ads *** gcc-3.2.3/gcc/ada/1ic.ads 2001-10-02 13:35:47.000000000 +0000 --- gcc-3.3/gcc/ada/1ic.ads 2002-03-14 10:58:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT Hi Integrity Edition. In accordance with the copyright of that -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/1ssecsta.adb gcc-3.3/gcc/ada/1ssecsta.adb *** gcc-3.2.3/gcc/ada/1ssecsta.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/1ssecsta.adb 2002-10-23 08:04:16.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . S E C O N D A R Y _ S T A C K -- + -- -- + -- 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- -- + -- 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 HI-E version of this package. + + with Unchecked_Conversion; + + package body System.Secondary_Stack is + + use type SSE.Storage_Offset; + + type Memory is array (Mark_Id range <>) of SSE.Storage_Element; + + type Stack_Id is record + Top : Mark_Id; + Last : Mark_Id; + Mem : Memory (1 .. Mark_Id'Last); + end record; + pragma Suppress_Initialization (Stack_Id); + + type Stack_Ptr is access Stack_Id; + + function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr); + + function Get_Sec_Stack return Stack_Ptr; + pragma Import (C, Get_Sec_Stack, "__gnat_get_secondary_stack"); + -- Return the address of the secondary stack. + -- In a multi-threaded environment, Sec_Stack should be a thread-local + -- variable. + + -- Possible implementation of Get_Sec_Stack in a single-threaded + -- environment: + -- + -- Chunk : aliased Memory (1 .. Default_Secondary_Stack_Size); + -- for Chunk'Alignment use Standard'Maximum_Alignment; + -- -- The secondary stack. + -- + -- function Get_Sec_Stack return Stack_Ptr is + -- begin + -- return From_Addr (Chunk'Address); + -- end Get_Sec_Stack; + -- + -- begin + -- SS_Init (Chunk'Address, Default_Secondary_Stack_Size); + -- end System.Secondary_Stack; + + ----------------- + -- SS_Allocate -- + ----------------- + + procedure SS_Allocate + (Address : out System.Address; + Storage_Size : SSE.Storage_Count) + is + Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment); + Max_Size : constant Mark_Id := + ((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align) + * Max_Align; + Sec_Stack : constant Stack_Ptr := Get_Sec_Stack; + + begin + if Sec_Stack.Top + Max_Size > Sec_Stack.Last then + raise Storage_Error; + end if; + + Address := Sec_Stack.Mem (Sec_Stack.Top)'Address; + Sec_Stack.Top := Sec_Stack.Top + Mark_Id (Max_Size); + end SS_Allocate; + + ------------- + -- SS_Free -- + ------------- + + procedure SS_Free (Stk : in out System.Address) is + begin + Stk := Null_Address; + end SS_Free; + + ------------- + -- SS_Init -- + ------------- + + procedure SS_Init + (Stk : System.Address; + Size : Natural := Default_Secondary_Stack_Size) + is + Stack : Stack_Ptr := From_Addr (Stk); + begin + pragma Assert (Size >= 2 * Mark_Id'Max_Size_In_Storage_Elements); + + Stack.Top := Stack.Mem'First; + Stack.Last := Mark_Id (Size) - 2 * Mark_Id'Max_Size_In_Storage_Elements; + end SS_Init; + + ------------- + -- SS_Mark -- + ------------- + + function SS_Mark return Mark_Id is + begin + return Get_Sec_Stack.Top; + end SS_Mark; + + ---------------- + -- SS_Release -- + ---------------- + + procedure SS_Release (M : Mark_Id) is + begin + Get_Sec_Stack.Top := M; + end SS_Release; + + end System.Secondary_Stack; diff -Nrc3pad gcc-3.2.3/gcc/ada/1ssecsta.ads gcc-3.3/gcc/ada/1ssecsta.ads *** gcc-3.2.3/gcc/ada/1ssecsta.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/1ssecsta.ads 2002-10-23 08:04:16.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . S E C O N D A R Y _ S T A C K -- + -- -- + -- 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- -- + -- 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; + + 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; + Size : Natural := Default_Secondary_Stack_Size); + -- Initialize the secondary stack with a main stack of the given Size. + -- + -- Stk is an "in" parameter that is already pointing to a memory area of + -- size Size. + -- + -- The secondary stack is fixed, and any attempt to allocate more than the + -- initial size will result in a Storage_Error being raised. + + procedure SS_Allocate + (Address : out System.Address; + Storage_Size : SSE.Storage_Count); + -- Allocate enough space for a 'Storage_Size' bytes object with Maximum + -- alignment. The address of the allocated space is returned in 'Address' + + procedure SS_Free (Stk : in out System.Address); + -- Release the memory allocated for the Secondary Stack. That is to say, + -- all the allocated chuncks. + -- Upon return, Stk will be set to System.Null_Address + + type Mark_Id is private; + -- Type used to mark the stack. + + function SS_Mark return Mark_Id; + -- Return the Mark corresponding to the current state of the stack + + procedure SS_Release (M : Mark_Id); + -- Restore the state of the stack corresponding to the mark M. If an + -- additional chunk have been allocated, it will never be freed during a + + private + + SS_Pool : Integer; + -- Unused entity that is just present to ease the sharing of the pool + -- mechanism for specific allocation/deallocation in the compiler + + type Mark_Id is new SSE.Integer_Address; + + end System.Secondary_Stack; diff -Nrc3pad gcc-3.2.3/gcc/ada/31soccon.ads gcc-3.3/gcc/ada/31soccon.ads *** gcc-3.2.3/gcc/ada/31soccon.ads 2001-10-02 13:35:47.000000000 +0000 --- gcc-3.3/gcc/ada/31soccon.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/31soliop.ads gcc-3.3/gcc/ada/31soliop.ads *** gcc-3.2.3/gcc/ada/31soliop.ads 2001-10-02 13:35:47.000000000 +0000 --- gcc-3.3/gcc/ada/31soliop.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3asoccon.ads gcc-3.3/gcc/ada/3asoccon.ads *** gcc-3.2.3/gcc/ada/3asoccon.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3asoccon.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3bsoccon.ads gcc-3.3/gcc/ada/3bsoccon.ads *** gcc-3.2.3/gcc/ada/3bsoccon.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3bsoccon.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3gsoccon.ads gcc-3.3/gcc/ada/3gsoccon.ads *** gcc-3.2.3/gcc/ada/3gsoccon.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3gsoccon.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3hsoccon.ads gcc-3.3/gcc/ada/3hsoccon.ads *** gcc-3.2.3/gcc/ada/3hsoccon.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3hsoccon.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3lsoccon.ads gcc-3.3/gcc/ada/3lsoccon.ads *** gcc-3.2.3/gcc/ada/3lsoccon.ads 2001-10-04 17:50:42.000000000 +0000 --- gcc-3.3/gcc/ada/3lsoccon.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,115 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T . S O C K E T S . C O N S T A N T S -- - -- -- - -- S p e c -- - -- -- - -- $Revision: 1.1 $ - -- -- - -- Copyright (C) 2001 Ada Core Technologies, Inc. -- - -- -- - -- GNAT is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the version for GNU/Linux - - package GNAT.Sockets.Constants is - - -- Families - - AF_INET : constant := 2; - AF_INET6 : constant := 10; - - -- Modes - - SOCK_STREAM : constant := 1; - SOCK_DGRAM : constant := 2; - - -- Socket Errors - - EBADF : constant := 9; - ENOTSOCK : constant := 88; - ENOTCONN : constant := 107; - ENOBUFS : constant := 105; - EOPNOTSUPP : constant := 95; - EFAULT : constant := 14; - EWOULDBLOCK : constant := 11; - EADDRNOTAVAIL : constant := 99; - EMSGSIZE : constant := 90; - EADDRINUSE : constant := 98; - EINVAL : constant := 22; - EACCES : constant := 13; - EAFNOSUPPORT : constant := 97; - EISCONN : constant := 106; - ETIMEDOUT : constant := 110; - ECONNREFUSED : constant := 111; - ENETUNREACH : constant := 101; - EALREADY : constant := 114; - EINPROGRESS : constant := 115; - ENOPROTOOPT : constant := 92; - EPROTONOSUPPORT : constant := 93; - EINTR : constant := 4; - EIO : constant := 5; - ESOCKTNOSUPPORT : constant := 94; - - -- Host Errors - - HOST_NOT_FOUND : constant := 1; - TRY_AGAIN : constant := 2; - NO_ADDRESS : constant := 4; - NO_RECOVERY : constant := 3; - - -- Control Flags - - FIONBIO : constant := 21537; - FIONREAD : constant := 21531; - - -- Shutdown Modes - - SHUT_RD : constant := 0; - SHUT_WR : constant := 1; - SHUT_RDWR : constant := 2; - - -- Protocol Levels - - SOL_SOCKET : constant := 1; - IPPROTO_IP : constant := 0; - IPPROTO_UDP : constant := 17; - IPPROTO_TCP : constant := 6; - - -- Socket Options - - TCP_NODELAY : constant := 1; - SO_SNDBUF : constant := 7; - SO_RCVBUF : constant := 8; - SO_REUSEADDR : constant := 2; - SO_KEEPALIVE : constant := 9; - SO_LINGER : constant := 13; - SO_ERROR : constant := 4; - SO_BROADCAST : constant := 6; - IP_ADD_MEMBERSHIP : constant := 35; - IP_DROP_MEMBERSHIP : constant := 36; - IP_MULTICAST_TTL : constant := 33; - IP_MULTICAST_LOOP : constant := 34; - end GNAT.Sockets.Constants; --- 0 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3ssoccon.ads gcc-3.3/gcc/ada/3ssoccon.ads *** gcc-3.2.3/gcc/ada/3ssoccon.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3ssoccon.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3ssoliop.ads gcc-3.3/gcc/ada/3ssoliop.ads *** gcc-3.2.3/gcc/ada/3ssoliop.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3ssoliop.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3wsoccon.ads gcc-3.3/gcc/ada/3wsoccon.ads *** gcc-3.2.3/gcc/ada/3wsoccon.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3wsoccon.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3wsocthi.adb gcc-3.3/gcc/ada/3wsocthi.adb *** gcc-3.2.3/gcc/ada/3wsocthi.adb 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3wsocthi.adb 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3wsocthi.ads gcc-3.3/gcc/ada/3wsocthi.ads *** gcc-3.2.3/gcc/ada/3wsocthi.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3wsocthi.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/3wsoliop.ads gcc-3.3/gcc/ada/3wsoliop.ads *** gcc-3.2.3/gcc/ada/3wsoliop.ads 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/3wsoliop.ads 2002-03-14 10:58:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/41intnam.ads gcc-3.3/gcc/ada/41intnam.ads *** gcc-3.2.3/gcc/ada/41intnam.ads 2002-05-04 03:27:12.000000000 +0000 --- gcc-3.3/gcc/ada/41intnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,13 ---- -- -- -- 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- -- *************** *** 43,49 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handler - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping with System.OS_Interface; -- used for names of interrupts --- 42,47 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/42intnam.ads gcc-3.3/gcc/ada/42intnam.ads *** gcc-3.2.3/gcc/ada/42intnam.ads 2002-05-04 03:27:12.000000000 +0000 --- gcc-3.3/gcc/ada/42intnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,13 ---- -- -- -- 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- -- *************** *** 43,49 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handler - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping with System.OS_Interface; -- used for names of interrupts --- 42,47 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4aintnam.ads gcc-3.3/gcc/ada/4aintnam.ads *** gcc-3.2.3/gcc/ada/4aintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4aintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- 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- -- *************** *** 43,49 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handler - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping with System.OS_Interface; -- used for names of interrupts --- 42,47 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4cintnam.ads gcc-3.3/gcc/ada/4cintnam.ads *** gcc-3.2.3/gcc/ada/4cintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4cintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- 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- -- *************** *** 48,54 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handler - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping -- This target-dependent package spec contains names of interrupts -- supported by the local system. --- 47,52 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4dintnam.ads gcc-3.3/gcc/ada/4dintnam.ads *** gcc-3.2.3/gcc/ada/4dintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4dintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- 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- -- *************** *** 43,49 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: Made available for Ada handler - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping -- This target-dependent package spec contains names of interrupts -- supported by the local system. --- 42,47 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4gintnam.ads gcc-3.3/gcc/ada/4gintnam.ads *** gcc-3.2.3/gcc/ada/4gintnam.ads 2001-10-26 00:50:40.000000000 +0000 --- gcc-3.3/gcc/ada/4gintnam.ads 2002-03-14 10:58:23.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.3 $ -- -- ! -- Copyright (C) 1997-2001, Florida State University -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU Library General Public License as published by the -- --- 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 -- *************** *** 50,56 **** -- (Pthread library): -- -- SIGINT: made available for Ada handler - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping -- This target-dependent package spec contains names of interrupts -- supported by the local system. --- 49,54 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4hexcpol.adb gcc-3.3/gcc/ada/4hexcpol.adb *** gcc-3.2.3/gcc/ada/4hexcpol.adb 2002-05-04 03:27:12.000000000 +0000 --- gcc-3.3/gcc/ada/4hexcpol.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4hintnam.ads gcc-3.3/gcc/ada/4hintnam.ads *** gcc-3.2.3/gcc/ada/4hintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4hintnam.ads 2002-03-14 10:58:23.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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-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- -- *************** *** 44,50 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handler - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping -- This target-dependent package spec contains names of interrupts -- supported by the local system. --- 43,48 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4lintnam.ads gcc-3.3/gcc/ada/4lintnam.ads *** gcc-3.2.3/gcc/ada/4lintnam.ads 2002-05-04 03:27:12.000000000 +0000 --- gcc-3.3/gcc/ada/4lintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.12.1 $ -- -- ! -- 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,13 ---- -- -- -- 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- -- *************** *** 48,54 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handler - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping -- This target-dependent package spec contains names of interrupts -- supported by the local system. --- 47,52 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4mintnam.ads gcc-3.3/gcc/ada/4mintnam.ads *** gcc-3.2.3/gcc/ada/4mintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4mintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- 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- -- *************** *** 43,49 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handlers - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping -- This target-dependent package spec contains names of interrupts -- supported by the local system. --- 42,47 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4nintnam.ads gcc-3.3/gcc/ada/4nintnam.ads *** gcc-3.2.3/gcc/ada/4nintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4nintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- (No Tasking Version) -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1991,92,93,94,95,1996 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4ointnam.ads gcc-3.3/gcc/ada/4ointnam.ads *** gcc-3.2.3/gcc/ada/4ointnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4ointnam.ads 2002-03-14 10:58:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-1997 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4onumaux.ads gcc-3.3/gcc/ada/4onumaux.ads *** gcc-3.2.3/gcc/ada/4onumaux.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4onumaux.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- (C Library Version for x86) -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4pintnam.ads gcc-3.3/gcc/ada/4pintnam.ads *** gcc-3.2.3/gcc/ada/4pintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4pintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- 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- -- *************** *** 43,49 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handlers - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping -- This target-dependent package spec contains names of interrupts -- supported by the local system. --- 42,47 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4rintnam.ads gcc-3.3/gcc/ada/4rintnam.ads *** gcc-3.2.3/gcc/ada/4rintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4rintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- 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- -- *************** *** 47,53 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handlers - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping -- This target-dependent package spec contains names of interrupts -- supported by the local system. --- 46,51 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4sintnam.ads gcc-3.3/gcc/ada/4sintnam.ads *** gcc-3.2.3/gcc/ada/4sintnam.ads 2002-05-07 08:22:01.000000000 +0000 --- gcc-3.3/gcc/ada/4sintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- 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- -- *************** *** 48,54 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handlers - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping with System.OS_Interface; -- used for names of interrupts --- 47,52 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4uintnam.ads gcc-3.3/gcc/ada/4uintnam.ads *** gcc-3.2.3/gcc/ada/4uintnam.ads 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/4uintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- 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- -- *************** *** 43,49 **** -- The pragma Unreserve_All_Interrupts affects the following signal(s): -- -- SIGINT: made available for Ada handlers - -- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping with System.OS_Interface; -- used for names of interrupts --- 42,47 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4vcaldel.adb gcc-3.3/gcc/ada/4vcaldel.adb *** gcc-3.2.3/gcc/ada/4vcaldel.adb 2001-10-02 13:35:48.000000000 +0000 --- gcc-3.3/gcc/ada/4vcaldel.adb 2002-03-14 10:58:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2000 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4vcalend.adb gcc-3.3/gcc/ada/4vcalend.adb *** gcc-3.2.3/gcc/ada/4vcalend.adb 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/4vcalend.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Ada.Calendar is *** 60,68 **** -- Some basic constants used throughout - Days_In_Month : constant array (Month_Number) of Day_Number := - (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); - function To_Relative_Time (D : Duration) return Time; function To_Relative_Time (D : Duration) return Time is --- 59,64 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4vcalend.ads gcc-3.3/gcc/ada/4vcalend.ads *** gcc-3.2.3/gcc/ada/4vcalend.ads 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/4vcalend.ads 2002-03-14 10:58:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4vintnam.ads gcc-3.3/gcc/ada/4vintnam.ads *** gcc-3.2.3/gcc/ada/4vintnam.ads 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/4vintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4wcalend.adb gcc-3.3/gcc/ada/4wcalend.adb *** gcc-3.2.3/gcc/ada/4wcalend.adb 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/4wcalend.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4wexcpol.adb gcc-3.3/gcc/ada/4wexcpol.adb *** gcc-3.2.3/gcc/ada/4wexcpol.adb 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/4wexcpol.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4wintnam.ads gcc-3.3/gcc/ada/4wintnam.ads *** gcc-3.2.3/gcc/ada/4wintnam.ads 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/4wintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1997-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4zintnam.ads gcc-3.3/gcc/ada/4zintnam.ads *** gcc-3.2.3/gcc/ada/4zintnam.ads 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/4zintnam.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** *** 34,53 **** ------------------------------------------------------------------------------ -- This is the VxWorks version of this package. - -- - -- The following signals are reserved by the run time: - -- - -- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT - -- - -- The pragma Unreserve_All_Interrupts affects the following signal(s): - -- - -- none - - -- This target-dependent package spec contains names of interrupts - -- supported by the local system. with System.OS_Interface; - with System.VxWorks; package Ada.Interrupts.Names is --- 33,40 ---- *************** package Ada.Interrupts.Names is *** 55,190 **** range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt; -- Range of values that can be used for hardware interrupts. - -- The following constants can be used for software interrupts mapped to - -- user-level signals: - - SIGHUP : constant Interrupt_ID; - -- hangup - - SIGINT : constant Interrupt_ID; - -- interrupt - - SIGQUIT : constant Interrupt_ID; - -- quit - - SIGILL : constant Interrupt_ID; - -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID; - -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID; - -- IOT instruction - - SIGABRT : constant Interrupt_ID; - -- used by abort, replace SIGIOT - - SIGEMT : constant Interrupt_ID; - -- EMT instruction - - SIGFPE : constant Interrupt_ID; - -- floating point exception - - SIGKILL : constant Interrupt_ID; - -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID; - -- bus error - - SIGSEGV : constant Interrupt_ID; - -- segmentation violation - - SIGSYS : constant Interrupt_ID; - -- bad argument to system call - - SIGPIPE : constant Interrupt_ID; - -- no one to read it - - SIGALRM : constant Interrupt_ID; - -- alarm clock - - SIGTERM : constant Interrupt_ID; - -- software termination signal from kill - - SIGURG : constant Interrupt_ID; - -- urgent condition on IO channel - - SIGSTOP : constant Interrupt_ID; - -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID; - -- user stop requested from tty - - SIGCONT : constant Interrupt_ID; - -- stopped process has been continued - - SIGCHLD : constant Interrupt_ID; - -- child status change - - SIGTTIN : constant Interrupt_ID; - -- background tty read attempted - - SIGTTOU : constant Interrupt_ID; - -- background tty write attempted - - SIGIO : constant Interrupt_ID; - -- input/output possible, - - SIGXCPU : constant Interrupt_ID; - -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID; - -- filesize limit exceeded - - SIGVTALRM : constant Interrupt_ID; - -- virtual timer expired - - SIGPROF : constant Interrupt_ID; - -- profiling timer expired - - SIGWINCH : constant Interrupt_ID; - -- window size change - - SIGUSR1 : constant Interrupt_ID; - -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID; - -- user defined signal 2 - - private - - Signal_Base : constant := System.VxWorks.Num_HW_Interrupts; - - SIGHUP : constant Interrupt_ID := 1 + Signal_Base; - SIGINT : constant Interrupt_ID := 2 + Signal_Base; - SIGQUIT : constant Interrupt_ID := 3 + Signal_Base; - SIGILL : constant Interrupt_ID := 4 + Signal_Base; - SIGTRAP : constant Interrupt_ID := 5 + Signal_Base; - SIGIOT : constant Interrupt_ID := 6 + Signal_Base; - SIGABRT : constant Interrupt_ID := 6 + Signal_Base; - SIGEMT : constant Interrupt_ID := 7 + Signal_Base; - SIGFPE : constant Interrupt_ID := 8 + Signal_Base; - SIGKILL : constant Interrupt_ID := 9 + Signal_Base; - SIGBUS : constant Interrupt_ID := 10 + Signal_Base; - SIGSEGV : constant Interrupt_ID := 11 + Signal_Base; - SIGSYS : constant Interrupt_ID := 12 + Signal_Base; - SIGPIPE : constant Interrupt_ID := 13 + Signal_Base; - SIGALRM : constant Interrupt_ID := 14 + Signal_Base; - SIGTERM : constant Interrupt_ID := 15 + Signal_Base; - SIGURG : constant Interrupt_ID := 16 + Signal_Base; - SIGSTOP : constant Interrupt_ID := 17 + Signal_Base; - SIGTSTP : constant Interrupt_ID := 18 + Signal_Base; - SIGCONT : constant Interrupt_ID := 19 + Signal_Base; - SIGCHLD : constant Interrupt_ID := 20 + Signal_Base; - SIGTTIN : constant Interrupt_ID := 21 + Signal_Base; - SIGTTOU : constant Interrupt_ID := 22 + Signal_Base; - SIGIO : constant Interrupt_ID := 23 + Signal_Base; - SIGXCPU : constant Interrupt_ID := 24 + Signal_Base; - SIGXFSZ : constant Interrupt_ID := 25 + Signal_Base; - SIGVTALRM : constant Interrupt_ID := 26 + Signal_Base; - SIGPROF : constant Interrupt_ID := 27 + Signal_Base; - SIGWINCH : constant Interrupt_ID := 28 + Signal_Base; - SIGUSR1 : constant Interrupt_ID := 30 + Signal_Base; - SIGUSR2 : constant Interrupt_ID := 31 + Signal_Base; - end Ada.Interrupts.Names; --- 42,45 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4znumaux.ads gcc-3.3/gcc/ada/4znumaux.ads *** gcc-3.2.3/gcc/ada/4znumaux.ads 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/4znumaux.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- (C Library Version, VxWorks) -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4zsytaco.adb gcc-3.3/gcc/ada/4zsytaco.adb *** gcc-3.2.3/gcc/ada/4zsytaco.adb 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/4zsytaco.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/4zsytaco.ads gcc-3.3/gcc/ada/4zsytaco.ads *** gcc-3.2.3/gcc/ada/4zsytaco.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/4zsytaco.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/51osinte.adb gcc-3.3/gcc/ada/51osinte.adb *** gcc-3.2.3/gcc/ada/51osinte.adb 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/51osinte.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/51osinte.ads gcc-3.3/gcc/ada/51osinte.ads *** gcc-3.2.3/gcc/ada/51osinte.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/51osinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/52osinte.adb gcc-3.3/gcc/ada/52osinte.adb *** gcc-3.2.3/gcc/ada/52osinte.adb 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/52osinte.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/52osinte.ads gcc-3.3/gcc/ada/52osinte.ads *** gcc-3.2.3/gcc/ada/52osinte.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/52osinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/52system.ads gcc-3.3/gcc/ada/52system.ads *** gcc-3.2.3/gcc/ada/52system.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/52system.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (LynxOS PPC/x86 Version) -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,14 ---- -- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 88,119 **** -- Other System-Dependent Declarations type Bit_Order is (High_Order_First, Low_Order_First); ! Default_Bit_Order : constant Bit_Order := ! Bit_Order'Val (Standard'Default_Bit_Order); -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 87,104 ---- -- 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 *************** private *** 131,138 **** --- 116,126 ---- -- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/53osinte.ads gcc-3.3/gcc/ada/53osinte.ads *** gcc-3.2.3/gcc/ada/53osinte.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/53osinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/54osinte.ads gcc-3.3/gcc/ada/54osinte.ads *** gcc-3.2.3/gcc/ada/54osinte.ads 2001-10-02 13:42:24.000000000 +0000 --- gcc-3.3/gcc/ada/54osinte.ads 2002-03-14 10:58:27.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5amastop.adb gcc-3.3/gcc/ada/5amastop.adb *** gcc-3.2.3/gcc/ada/5amastop.adb 2001-10-02 13:42:24.000000000 +0000 --- gcc-3.3/gcc/ada/5amastop.adb 2002-03-14 10:58:27.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (Version for Alpha/Dec Unix) -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- -- -- --- 7,12 ---- *************** package body System.Machine_State_Operat *** 87,97 **** ------------------------ procedure Free_Machine_State (M : in out Machine_State) is - procedure Gnat_Free (M : in Machine_State); - pragma Import (C, Gnat_Free, "__gnat_free"); - begin ! Gnat_Free (M); M := Machine_State (Null_Address); end Free_Machine_State; --- 86,93 ---- ------------------------ procedure Free_Machine_State (M : in out Machine_State) is begin ! Memory.Free (Address (M)); M := Machine_State (Null_Address); end Free_Machine_State; diff -Nrc3pad gcc-3.2.3/gcc/ada/5aosinte.adb gcc-3.3/gcc/ada/5aosinte.adb *** gcc-3.2.3/gcc/ada/5aosinte.adb 2001-10-02 13:42:24.000000000 +0000 --- gcc-3.3/gcc/ada/5aosinte.adb 2002-03-14 10:58:27.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5aosinte.ads gcc-3.3/gcc/ada/5aosinte.ads *** gcc-3.2.3/gcc/ada/5aosinte.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/5aosinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5asystem.ads gcc-3.3/gcc/ada/5asystem.ads *** gcc-3.2.3/gcc/ada/5asystem.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/5asystem.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (DEC Unix Version) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 := 64; ! Memory_Size : constant := 2 ** 64; -- Address comparison *************** pragma Pure (System); *** 92,118 **** -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! ! Max_Interrupt_Priority : constant Positive := 31; ! ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 91,104 ---- -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 60; ! Max_Interrupt_Priority : constant Positive := 63; ! subtype Any_Priority is Integer range 0 .. 63; ! subtype Priority is Any_Priority range 0 .. 60; ! subtype Interrupt_Priority is Any_Priority range 61 .. 63; ! Default_Priority : constant Priority := 30; private *************** private *** 130,139 **** -- of the individual switch values. AAMP : constant Boolean := False; Command_Line_Args : constant Boolean := True; Denorm : 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; --- 116,128 ---- -- 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 := 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; *************** private *** 143,151 **** 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; -- Note: Denorm is False because denormals are only handled properly -- if the -mieee switch is set, and we do not require this usage. --- 132,140 ---- 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. *************** private *** 193,229 **** -- 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); end System; --- 182,210 ---- -- Suppress initialization in case gnat.adc specifies Normalize_Scalars Underlying_Priorities : constant Priorities_Mapping := ! ! (Priority'First => 0, ! ! 1 => 1, 2 => 2, 3 => 3, 4 => 4, 5 => 5, ! 6 => 6, 7 => 7, 8 => 8, 9 => 9, 10 => 10, ! 11 => 11, 12 => 12, 13 => 13, 14 => 14, 15 => 15, ! 16 => 16, 17 => 17, 18 => 18, 19 => 19, 20 => 20, ! 21 => 21, 22 => 22, 23 => 23, 24 => 24, 25 => 25, ! 26 => 26, 27 => 27, 28 => 28, 29 => 29, ! ! Default_Priority => 30, ! ! 31 => 31, 32 => 32, 33 => 33, 34 => 34, 35 => 35, ! 36 => 36, 37 => 37, 38 => 38, 39 => 39, 40 => 40, ! 41 => 41, 42 => 42, 43 => 43, 44 => 44, 45 => 45, ! 46 => 46, 47 => 47, 48 => 48, 49 => 49, 50 => 50, ! 51 => 51, 52 => 52, 53 => 53, 54 => 54, 55 => 55, ! 56 => 56, 57 => 57, 58 => 58, 59 => 59, ! ! Priority'Last => 60, ! ! 61 => 61, 62 => 62, ! ! Interrupt_Priority'Last => 63); end System; diff -Nrc3pad gcc-3.2.3/gcc/ada/5ataprop.adb gcc-3.3/gcc/ada/5ataprop.adb *** gcc-3.2.3/gcc/ada/5ataprop.adb 2001-12-16 01:13:27.000000000 +0000 --- gcc-3.3/gcc/ada/5ataprop.adb 2002-10-23 08:27:54.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 99,113 **** package SSL renames System.Soft_Links; ! ----------------- ! -- Local Data -- ! ----------------- -- The followings are logically constants, but need to be initialized -- at run time. ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 97,113 ---- 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 Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 221,227 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as All_Tasks_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. --- 221,227 ---- -- 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. *************** package body System.Task_Primitives.Oper *** 317,349 **** All_Tasks_Link := Self_ID.Common.All_Tasks_Link; Current_Prio := Get_Priority (Self_ID); ! -- if there is no other task, no need to check priorities ! if All_Tasks_Link /= Null_Task and then ! L.Ceiling < Interfaces.C.int (Current_Prio) then Ceiling_Violation := True; return; end if; end if; Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); Ceiling_Violation := False; end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; begin ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; begin ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Write_Lock; --------------- --- 317,356 ---- All_Tasks_Link := Self_ID.Common.All_Tasks_Link; Current_Prio := Get_Priority (Self_ID); ! -- If there is no other task, no need to check priorities ! ! if All_Tasks_Link /= Null_Task ! and then L.Ceiling < Interfaces.C.int (Current_Prio) ! then Ceiling_Violation := True; return; end if; end if; Result := pthread_mutex_lock (L.L'Access); pragma Assert (Result = 0); Ceiling_Violation := False; end Write_Lock; ! procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) ! is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); ! end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Write_Lock; --------------- *************** package body System.Task_Primitives.Oper *** 366,383 **** pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock) is Result : Interfaces.C.int; begin ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; begin ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Unlock; ----------- --- 373,394 ---- pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); ! end if; end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Unlock; ----------- *************** package body System.Task_Primitives.Oper *** 390,398 **** is Result : Interfaces.C.int; begin ! pragma Assert (Self_ID = Self); ! Result := pthread_cond_wait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); -- EINTR is not considered a failure. --- 401,413 ---- 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. *************** package body System.Task_Primitives.Oper *** 437,444 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level or else Self_ID.Pending_Priority_Change; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 452,467 ---- 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; *************** package body System.Task_Primitives.Oper *** 477,482 **** --- 500,510 ---- -- check for pending abort and priority change below! :( SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); if Mode = Relative then *************** package body System.Task_Primitives.Oper *** 498,505 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 526,538 ---- 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; *************** package body System.Task_Primitives.Oper *** 512,517 **** --- 545,555 ---- end if; Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + Yield; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 612,618 **** Self_ID.Common.LL.Thread := pthread_self; Specific.Set (Self_ID); ! Lock_All_Tasks_List; for J in Known_Tasks'Range loop if Known_Tasks (J) = null then --- 650,656 ---- Self_ID.Common.LL.Thread := pthread_self; Specific.Set (Self_ID); ! Lock_RTS; for J in Known_Tasks'Range loop if Known_Tasks (J) = null then *************** package body System.Task_Primitives.Oper *** 622,628 **** end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 660,666 ---- end if; end loop; ! Unlock_RTS; end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 644,688 **** Cond_Attr : aliased pthread_condattr_t; begin ! Result := pthread_mutexattr_init (Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; ! end if; ! Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, ! Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; end if; - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! Succeeded := False; ! return; end if; - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - if Result = 0 then Succeeded := True; else ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); Succeeded := False; end if; --- 682,723 ---- 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); ! 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; *************** package body System.Task_Primitives.Oper *** 829,841 **** Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; end if; Free (Tmp); end Finalize_TCB; --- 864,881 ---- 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); end Finalize_TCB; *************** package body System.Task_Primitives.Oper *** 891,913 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 931,953 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 944,950 **** begin Environment_Task_ID := Environment_Task; ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); -- Initialize the lock used to synchronize chain of all ATCBs. Specific.Initialize (Environment_Task); --- 984,990 ---- 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); *************** package body System.Task_Primitives.Oper *** 971,977 **** 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 --- 1011,1016 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5atasinf.ads gcc-3.3/gcc/ada/5atasinf.ads *** gcc-3.2.3/gcc/ada/5atasinf.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/5atasinf.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- (Compiler Interface) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2000 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5ataspri.ads gcc-3.3/gcc/ada/5ataspri.ads *** gcc-3.2.3/gcc/ada/5ataspri.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/5ataspri.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5atpopsp.adb gcc-3.3/gcc/ada/5atpopsp.adb *** gcc-3.2.3/gcc/ada/5atpopsp.adb 2001-12-16 01:13:27.000000000 +0000 --- gcc-3.3/gcc/ada/5atpopsp.adb 2002-10-23 08:27:54.000000000 +0000 *************** *** 7,15 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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,14 ---- -- -- -- 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- -- *************** *** 29,44 **** -- 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 POSIX version of this package where foreign threads are -- recognized. ! -- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and RTEMS ! -- use this version. with System.Soft_Links; -- used to initialize TSD for a C thread, in function Self --- 28,45 ---- -- 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 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 *************** package body Specific is *** 71,77 **** 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. --- 72,78 ---- 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. *************** package body Specific is *** 109,115 **** -- 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; --- 110,116 ---- -- 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; *************** package body Specific is *** 195,201 **** -- Must not unlock until Next_ATCB is again allocated. ! Unlock (All_Tasks_L'Access); return Self_ID; end New_Fake_ATCB; --- 196,202 ---- -- Must not unlock until Next_ATCB is again allocated. ! Unlock_RTS; return Self_ID; end New_Fake_ATCB; *************** package body Specific is *** 205,211 **** procedure Initialize (Environment_Task : Task_ID) is Result : Interfaces.C.int; - begin Result := pthread_key_create (ATCB_Key'Access, null); pragma Assert (Result = 0); --- 206,211 ---- *************** package body Specific is *** 223,229 **** 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); --- 223,228 ---- *************** package body Specific is *** 233,269 **** -- 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; - begin Result := pthread_getspecific (ATCB_Key); --- 232,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. ! -- 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; begin Result := pthread_getspecific (ATCB_Key); diff -Nrc3pad gcc-3.2.3/gcc/ada/5avxwork.ads gcc-3.3/gcc/ada/5avxwork.ads *** gcc-3.2.3/gcc/ada/5avxwork.ads 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/5avxwork.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1998-2001 Free Software Foundation -- -- -- -- GNARL is 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) 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- -- *************** package System.VxWorks is *** 42,109 **** package IC renames Interfaces.C; ! -- Define enough of a Wind Task Control Block in order to ! -- obtain the inherited priority. When porting this to ! -- different versions of VxWorks (this is based on 5.3[.1]), ! -- be sure to look at the definition for WIND_TCB located ! -- in $WIND_BASE/target/h/taskLib.h ! ! type Wind_Fill_1 is array (0 .. 16#77#) of IC.unsigned_char; ! type Wind_Fill_2 is array (16#80# .. 16#1c7#) of IC.unsigned_char; ! type Wind_Fill_3 is array (16#1d8# .. 16#777#) of IC.unsigned_char; ! ! type Wind_TCB is record ! Fill_1 : Wind_Fill_1; -- 0x00 - 0x77 ! Priority : IC.int; -- 0x78 - 0x7b, current (inherited) priority ! Normal_Priority : IC.int; -- 0x7c - 0x7f, base priority ! Fill_2 : Wind_Fill_2; -- 0x80 - 0x1c7 ! spare1 : Address; -- 0x1c8 - 0x1cb ! spare2 : Address; -- 0x1cc - 0x1cf ! spare3 : Address; -- 0x1d0 - 0x1d3 ! spare4 : Address; -- 0x1d4 - 0x1d7 ! ! -- Fill_3 is much smaller on the board runtime, but the larger size ! -- below keeps this record compatible with vxsim. ! ! Fill_3 : Wind_Fill_3; -- 0x1d8 - 0x777 ! end record; ! type Wind_TCB_Ptr is access Wind_TCB; ! ! ! -- Floating point context record. Alpha version FP_NUM_DREGS : constant := 32; type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; type FP_CONTEXT is record ! fpx : Fpx_Array; fpcsr : IC.long; end record; pragma Convention (C, FP_CONTEXT); ! -- Number of entries in hardware interrupt vector table. Value of ! -- 0 disables hardware interrupt handling until it can be tested ! Num_HW_Interrupts : constant := 0; ! ! -- VxWorks 5.3 and 5.4 version ! type TASK_DESC is record ! td_id : IC.int; -- task id ! td_name : Address; -- name of task ! td_priority : IC.int; -- task priority ! td_status : IC.int; -- task status ! td_options : IC.int; -- task option bits (see below) ! td_entry : Address; -- original entry point of task ! td_sp : Address; -- saved stack pointer ! td_pStackBase : Address; -- the bottom of the stack ! td_pStackLimit : Address; -- the effective end of the stack ! td_pStackEnd : Address; -- the actual end of the stack ! td_stackSize : IC.int; -- size of stack in bytes ! td_stackCurrent : IC.int; -- current stack usage in bytes ! td_stackHigh : IC.int; -- maximum stack usage in bytes ! td_stackMargin : IC.int; -- current stack margin in bytes ! td_errorStatus : IC.int; -- most recent task error status ! td_delay : IC.int; -- delay/timeout ticks ! end record; ! pragma Convention (C, TASK_DESC); end System.VxWorks; --- 41,58 ---- package IC renames Interfaces.C; ! -- Floating point context record. Alpha version FP_NUM_DREGS : constant := 32; type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; type FP_CONTEXT is record ! fpx : Fpx_Array; fpcsr : IC.long; end record; 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.2.3/gcc/ada/5bosinte.adb gcc-3.3/gcc/ada/5bosinte.adb *** gcc-3.2.3/gcc/ada/5bosinte.adb 2001-10-02 13:42:25.000000000 +0000 --- gcc-3.3/gcc/ada/5bosinte.adb 2002-10-23 08:27:54.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** package body System.OS_Interface is *** 140,146 **** function sched_yield return int is procedure pthread_yield; ! pragma Import (C, pthread_yield, "pthread_yield"); begin pthread_yield; --- 138,144 ---- function sched_yield return int is procedure pthread_yield; ! pragma Import (C, pthread_yield, "sched_yield"); begin pthread_yield; diff -Nrc3pad gcc-3.2.3/gcc/ada/5bosinte.ads gcc-3.3/gcc/ada/5bosinte.ads *** gcc-3.2.3/gcc/ada/5bosinte.ads 2002-05-04 03:27:13.000000000 +0000 --- gcc-3.3/gcc/ada/5bosinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5bsystem.ads gcc-3.3/gcc/ada/5bsystem.ads *** gcc-3.2.3/gcc/ada/5bsystem.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5bsystem.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 5,15 **** -- S Y S T E M -- -- -- -- S p e c -- ! -- (AIX/PPC Version) -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 5,14 ---- -- S Y S T E M -- -- -- -- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 88,119 **** -- Other System-Dependent Declarations type Bit_Order is (High_Order_First, Low_Order_First); ! Default_Bit_Order : constant Bit_Order := ! Bit_Order'Val (Standard'Default_Bit_Order); -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 87,104 ---- -- 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 *************** private *** 131,138 **** --- 116,126 ---- -- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5cosinte.ads gcc-3.3/gcc/ada/5cosinte.ads *** gcc-3.2.3/gcc/ada/5cosinte.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5cosinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5dosinte.ads gcc-3.3/gcc/ada/5dosinte.ads *** gcc-3.2.3/gcc/ada/5dosinte.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5dosinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5esystem.ads gcc-3.3/gcc/ada/5esystem.ads *** gcc-3.2.3/gcc/ada/5esystem.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5esystem.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (X86 Solaris Version) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,14 ---- -- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 92,118 **** -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 91,104 ---- -- 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 *************** private *** 130,137 **** --- 116,126 ---- -- 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; *************** private *** 145,150 **** 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; --- 134,139 ---- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5etpopse.adb gcc-3.3/gcc/ada/5etpopse.adb *** gcc-3.2.3/gcc/ada/5etpopse.adb 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/5etpopse.adb 2002-03-14 10:58:29.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-1998, Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5fintman.adb gcc-3.3/gcc/ada/5fintman.adb *** gcc-3.2.3/gcc/ada/5fintman.adb 2001-10-02 13:42:25.000000000 +0000 --- gcc-3.3/gcc/ada/5fintman.adb 2002-03-14 10:58:29.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2001, Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5fosinte.ads gcc-3.3/gcc/ada/5fosinte.ads *** gcc-3.2.3/gcc/ada/5fosinte.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5fosinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5fsystem.ads gcc-3.3/gcc/ada/5fsystem.ads *** gcc-3.2.3/gcc/ada/5fsystem.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5fsystem.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (SGI Irix, o32 ABI) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 92,118 **** -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 91,104 ---- -- 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 *************** private *** 130,137 **** --- 116,126 ---- -- 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 := 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5ftaprop.adb gcc-3.3/gcc/ada/5ftaprop.adb *** gcc-3.2.3/gcc/ada/5ftaprop.adb 2001-12-16 01:13:27.000000000 +0000 --- gcc-3.3/gcc/ada/5ftaprop.adb 2002-10-23 08:27:54.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 117,124 **** ATCB_Key : aliased pthread_key_t; -- Key used to find the Ada Task_ID associated with a thread ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Locking_Rules (spec). Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 115,124 ---- 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. *************** package body System.Task_Primitives.Oper *** 206,212 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as All_Tasks_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. --- 206,212 ---- -- 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. *************** package body System.Task_Primitives.Oper *** 308,314 **** procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; - begin Result := pthread_mutex_lock (L); Ceiling_Violation := Result = EINVAL; --- 308,313 ---- *************** package body System.Task_Primitives.Oper *** 318,337 **** pragma Assert (Result = 0 or else Result = EINVAL); end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Write_Lock; --------------- --- 317,340 ---- 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 ! 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; --------------- *************** package body System.Task_Primitives.Oper *** 349,374 **** procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Unlock; ----------- --- 352,378 ---- procedure Unlock (L : access Lock) is Result : Interfaces.C.int; begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); ! end if; end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Unlock; ----------- *************** package body System.Task_Primitives.Oper *** 381,389 **** is Result : Interfaces.C.int; begin ! pragma Assert (Self_ID = Self); ! Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access); -- EINTR is not considered a failure. --- 385,397 ---- 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. *************** package body System.Task_Primitives.Oper *** 424,431 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level or else Self_ID.Pending_Priority_Change; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 432,447 ---- 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; *************** package body System.Task_Primitives.Oper *** 461,466 **** --- 477,487 ---- -- check for pending abort and priority change below! :( SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); if Mode = Relative then *************** package body System.Task_Primitives.Oper *** 495,500 **** --- 516,526 ---- end if; Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + Yield; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 621,627 **** pragma Assert (Result = 0); end if; ! Lock_All_Tasks_List; for J in Known_Tasks'Range loop if Known_Tasks (J) = null then --- 647,653 ---- pragma Assert (Result = 0); end if; ! Lock_RTS; for J in Known_Tasks'Range loop if Known_Tasks (J) = null then *************** package body System.Task_Primitives.Oper *** 631,637 **** end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 657,663 ---- end if; end loop; ! Unlock_RTS; end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 652,679 **** Cond_Attr : aliased pthread_condattr_t; begin ! Initialize_Lock (Self_ID.Common.LL.L'Access, All_Tasks_Level); Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! ! Succeeded := False; ! return; end if; - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - if Result = 0 then Succeeded := True; else ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); Succeeded := False; end if; --- 678,704 ---- Cond_Attr : aliased pthread_condattr_t; begin ! if not Single_Lock then ! Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); ! end if; Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result = 0 then ! Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, ! Cond_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); end if; if Result = 0 then Succeeded := True; else ! if not Single_Lock then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; ! Succeeded := False; end if; *************** package body System.Task_Primitives.Oper *** 821,828 **** Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); --- 846,855 ---- 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); *************** package body System.Task_Primitives.Oper *** 885,907 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 912,934 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 939,945 **** Environment_Task_ID := Environment_Task; -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); Enter_Task (Environment_Task); --- 966,972 ---- 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); diff -Nrc3pad gcc-3.2.3/gcc/ada/5ftasinf.ads gcc-3.3/gcc/ada/5ftasinf.ads *** gcc-3.2.3/gcc/ada/5ftasinf.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5ftasinf.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- (Compiler Interface) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5ginterr.adb gcc-3.3/gcc/ada/5ginterr.adb *** gcc-3.2.3/gcc/ada/5ginterr.adb 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5ginterr.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1998-1999 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,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- -- *************** with System.Tasking.Initialization; *** 67,72 **** --- 66,74 ---- with System.Interrupt_Management; + with System.Parameters; + -- used for Single_Lock + with Interfaces.C; -- used for int *************** with Unchecked_Conversion; *** 74,79 **** --- 76,82 ---- package body System.Interrupts is + use Parameters; use Tasking; use Ada.Exceptions; use System.OS_Interface; *************** package body System.Interrupts is *** 649,659 **** --- 652,672 ---- end loop; Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Self_Id); Self_Id.Common.State := Interrupt_Server_Idle_Sleep; STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep); Self_Id.Common.State := Runnable; STPO.Unlock (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); -- Undefer abort here to allow a window for this task diff -Nrc3pad gcc-3.2.3/gcc/ada/5gintman.adb gcc-3.3/gcc/ada/5gintman.adb *** gcc-3.2.3/gcc/ada/5gintman.adb 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/5gintman.adb 2002-03-14 10:58:30.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-1998, Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5gmastop.adb gcc-3.3/gcc/ada/5gmastop.adb *** gcc-3.2.3/gcc/ada/5gmastop.adb 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5gmastop.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (Version for IRIX/MIPS) -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- *************** package body System.Machine_State_Operat *** 66,92 **** type Reg_Array is array (0 .. 31) of Uns64; ! type Sigcontext is ! record ! SC_Regmask : Uns32; -- 0 ! SC_Status : Uns32; -- 4 ! SC_PC : Uns64; -- 8 ! SC_Regs : Reg_Array; -- 16 ! SC_Fpregs : Reg_Array; -- 272 ! SC_Ownedfp : Uns32; -- 528 ! SC_Fpc_Csr : Uns32; -- 532 ! SC_Fpc_Eir : Uns32; -- 536 ! SC_Ssflags : Uns32; -- 540 ! SC_Mdhi : Uns64; -- 544 ! SC_Mdlo : Uns64; -- 552 ! SC_Cause : Uns64; -- 560 ! SC_Badvaddr : Uns64; -- 568 ! SC_Triggersave : Uns64; -- 576 ! SC_Sigset : Uns64; -- 584 ! SC_Fp_Rounded_Result : Uns64; -- 592 ! SC_Pancake : Uns64_Array (0 .. 5); ! SC_Pad : Uns64_Array (0 .. 26); ! end record; type Sigcontext_Ptr is access all Sigcontext; --- 65,90 ---- type Reg_Array is array (0 .. 31) of Uns64; ! type Sigcontext is record ! SC_Regmask : Uns32; -- 0 ! SC_Status : Uns32; -- 4 ! SC_PC : Uns64; -- 8 ! SC_Regs : Reg_Array; -- 16 ! SC_Fpregs : Reg_Array; -- 272 ! SC_Ownedfp : Uns32; -- 528 ! SC_Fpc_Csr : Uns32; -- 532 ! SC_Fpc_Eir : Uns32; -- 536 ! SC_Ssflags : Uns32; -- 540 ! SC_Mdhi : Uns64; -- 544 ! SC_Mdlo : Uns64; -- 552 ! SC_Cause : Uns64; -- 560 ! SC_Badvaddr : Uns64; -- 568 ! SC_Triggersave : Uns64; -- 576 ! SC_Sigset : Uns64; -- 584 ! SC_Fp_Rounded_Result : Uns64; -- 592 ! SC_Pancake : Uns64_Array (0 .. 5); ! SC_Pad : Uns64_Array (0 .. 26); ! end record; type Sigcontext_Ptr is access all Sigcontext; *************** package body System.Machine_State_Operat *** 253,263 **** ------------------------ procedure Free_Machine_State (M : in out Machine_State) is - procedure Gnat_Free (M : in Machine_State); - pragma Import (C, Gnat_Free, "__gnat_free"); - begin ! Gnat_Free (M); M := Machine_State (Null_Address); end Free_Machine_State; --- 251,258 ---- ------------------------ procedure Free_Machine_State (M : in out Machine_State) is begin ! Memory.Free (Address (M)); M := Machine_State (Null_Address); end Free_Machine_State; diff -Nrc3pad gcc-3.2.3/gcc/ada/5gosinte.ads gcc-3.3/gcc/ada/5gosinte.ads *** gcc-3.2.3/gcc/ada/5gosinte.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5gosinte.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5gproinf.adb gcc-3.3/gcc/ada/5gproinf.adb *** gcc-3.2.3/gcc/ada/5gproinf.adb 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5gproinf.adb 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5gproinf.ads gcc-3.3/gcc/ada/5gproinf.ads *** gcc-3.2.3/gcc/ada/5gproinf.ads 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/5gproinf.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5gsystem.ads gcc-3.3/gcc/ada/5gsystem.ads *** gcc-3.2.3/gcc/ada/5gsystem.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5gsystem.ads 2002-10-23 07:33:19.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (SGI Irix, n32 ABI) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 := 64; ! Memory_Size : constant := 2 ** 32; -- Address comparison *************** pragma Pure (System); *** 92,118 **** -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 91,104 ---- -- 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 *************** private *** 130,137 **** --- 116,126 ---- -- 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 := 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5gtaprop.adb gcc-3.3/gcc/ada/5gtaprop.adb *** gcc-3.2.3/gcc/ada/5gtaprop.adb 2001-12-16 01:13:27.000000000 +0000 --- gcc-3.3/gcc/ada/5gtaprop.adb 2002-10-23 08:27:54.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 106,120 **** -- The followings are logically constants, but need to be initialized -- at run time. ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). 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", ! "__gl_locking_policy"); Clock_Address : constant System.Address := System.Storage_Elements.To_Address (16#200F90#); --- 104,119 ---- -- The followings are logically constants, but need to be initialized -- at run time. ! Single_RTS_Lock : aliased RTS_Lock; ! -- This is a lock to allow only one thread of control in the RTS at ! -- a time; it is used to execute in mutual exclusion from all other tasks. ! -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. Locking_Policy : Character; ! pragma Import (C, Locking_Policy, "__gl_locking_policy"); Clock_Address : constant System.Address := System.Storage_Elements.To_Address (16#200F90#); *************** package body System.Task_Primitives.Oper *** 169,175 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as All_Tasks_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. --- 168,174 ---- -- 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. *************** package body System.Task_Primitives.Oper *** 267,273 **** procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; - begin Result := pthread_mutex_lock (L); --- 266,271 ---- *************** package body System.Task_Primitives.Oper *** 275,294 **** pragma Assert (Result /= FUNC_ERR); end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Write_Lock; --------------- --- 273,296 ---- pragma Assert (Result /= FUNC_ERR); end Write_Lock; ! procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) ! is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); ! end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Write_Lock; --------------- *************** package body System.Task_Primitives.Oper *** 306,437 **** procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Unlock; ! ------------- ! -- Sleep -- ! ------------- procedure Sleep (Self_ID : ST.Task_ID; ! Reason : System.Tasking.Task_States) is ! Result : Interfaces.C.int; - begin ! pragma Assert (Self_ID = Self); ! Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access); -- EINTR is not considered a failure. pragma Assert (Result = 0 or else Result = EINTR); end Sleep; - -- Note that we are relying heaviliy here on the GNAT feature - -- that Calendar.Time, System.Real_Time.Time, Duration, and - -- System.Real_Time.Time_Span are all represented in the same - -- way, i.e., as a 64-bit count of nanoseconds. - -- This allows us to always pass the timeout value as a Duration. - - -- ????? ......... - -- We are taking liberties here with the semantics of the delays. - -- That is, we make no distinction between delays on the Calendar clock - -- and delays on the Real_Time clock. That is technically incorrect, if - -- the Calendar clock happens to be reset or adjusted. - -- To solve this defect will require modification to the compiler - -- interface, so that it can pass through more information, to tell - -- us here which clock to use! - - -- cond_timedwait will return if any of the following happens: - -- 1) some other task did cond_signal on this condition variable - -- In this case, the return value is 0 - -- 2) the call just returned, for no good reason - -- This is called a "spurious wakeup". - -- In this case, the return value may also be 0. - -- 3) the time delay expires - -- In this case, the return value is ETIME - -- 4) this task received a signal, which was handled by some - -- handler procedure, and now the thread is resuming execution - -- UNIX calls this an "interrupted" system call. - -- In this case, the return value is EINTR - - -- If the cond_timedwait returns 0 or EINTR, it is still - -- possible that the time has actually expired, and by chance - -- a signal or cond_signal occurred at around the same time. - - -- We have also observed that on some OS's the value ETIME - -- will be returned, but the clock will show that the full delay - -- has not yet expired. - - -- For these reasons, we need to check the clock after return - -- from cond_timedwait. If the time has expired, we will set - -- Timedout = True. - - -- This check might be omitted for systems on which the - -- cond_timedwait() never returns early or wakes up spuriously. - - -- Annex D requires that completion of a delay cause the task - -- to go to the end of its priority queue, regardless of whether - -- the task actually was suspended by the delay. Since - -- cond_timedwait does not do this on Solaris, we add a call - -- to thr_yield at the end. We might do this at the beginning, - -- instead, but then the round-robin effect would not be the - -- same; the delayed task would be ahead of other tasks of the - -- same priority that awoke while it was sleeping. - - -- For Timed_Sleep, we are expecting possible cond_signals - -- to indicate other events (e.g., completion of a RV or - -- completion of the abortable part of an async. select), - -- we want to always return if interrupted. The caller will - -- be responsible for checking the task state to see whether - -- the wakeup was spurious, and to go back to sleep again - -- in that case. We don't need to check for pending abort - -- or priority change on the way in our out; that is the - -- caller's responsibility. - - -- For Timed_Delay, we are not expecting any cond_signals or - -- other interruptions, except for priority changes and aborts. - -- Therefore, we don't want to return unless the delay has - -- actually expired, or the call has been aborted. In this - -- case, since we want to implement the entire delay statement - -- semantics, we do need to check for pending abort and priority - -- changes. We can quietly handle priority changes inside the - -- procedure, since there is no entry-queue reordering involved. - ----------------- -- 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. - -- Yielded should be False unles we know for certain that the - -- operation resulted in the calling task going to the end of - -- the dispatching queue for its priority. - -- ????? - -- This version presumes the worst, so Yielded is always False. - -- On some targets, if cond_timedwait always yields, we could - -- set Yielded to True just before the cond_timedwait call. - procedure Timed_Sleep (Self_ID : Task_ID; Time : Duration; --- 308,362 ---- procedure Unlock (L : access Lock) is Result : Interfaces.C.int; begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); ! end if; end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Unlock; ! ----------- ! -- Sleep -- ! ----------- procedure Sleep (Self_ID : ST.Task_ID; ! Reason : System.Tasking.Task_States) ! is Result : Interfaces.C.int; begin ! if Single_Lock then ! Result := pthread_cond_wait ! (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); ! else ! Result := pthread_cond_wait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); ! end if; ! -- EINTR is not considered a failure. pragma Assert (Result = 0 or else Result = EINTR); end Sleep; ----------------- -- Timed_Sleep -- ----------------- procedure Timed_Sleep (Self_ID : Task_ID; Time : Duration; *************** package body System.Task_Primitives.Oper *** 461,468 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level or else Self_ID.Pending_Priority_Change; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 386,401 ---- 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; *************** package body System.Task_Primitives.Oper *** 482,491 **** -- 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; --- 415,420 ---- *************** package body System.Task_Primitives.Oper *** 495,507 **** Abs_Time : Duration; Request : aliased struct_timeval; 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; Write_Lock (Self_ID); if Mode = Relative then --- 424,441 ---- Abs_Time : Duration; Request : aliased struct_timeval; 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; + Write_Lock (Self_ID); if Mode = Relative then *************** package body System.Task_Primitives.Oper *** 523,530 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 457,469 ---- 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; *************** package body System.Task_Primitives.Oper *** 538,543 **** --- 477,487 ---- end if; Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + pthread_yield; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 578,587 **** procedure Wakeup (T : ST.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); --- 522,530 ---- procedure Wakeup (T : ST.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); *************** package body System.Task_Primitives.Oper *** 608,614 **** 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)); --- 551,556 ---- *************** package body System.Task_Primitives.Oper *** 631,639 **** 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; --- 573,579 ---- *************** package body System.Task_Primitives.Oper *** 642,658 **** pragma Assert (Result = 0); ! Lock_All_Tasks_List; ! for I in Known_Tasks'Range loop ! if Known_Tasks (I) = null then ! Known_Tasks (I) := Self_ID; ! Self_ID.Known_Tasks_Index := I; exit; end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 582,598 ---- pragma Assert (Result = 0); ! Lock_RTS; ! for J in Known_Tasks'Range loop ! if Known_Tasks (J) = null then ! Known_Tasks (J) := Self_ID; ! Self_ID.Known_Tasks_Index := J; exit; end if; end loop; ! Unlock_RTS; end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 669,699 **** ---------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is ! Result : Interfaces.C.int; Cond_Attr : aliased pthread_condattr_t; begin ! Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! Succeeded := False; ! return; end if; - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - if Result = 0 then Succeeded := True; else ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); Succeeded := False; end if; --- 609,639 ---- ---------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is ! Result : Interfaces.C.int; Cond_Attr : aliased pthread_condattr_t; begin ! if not Single_Lock then ! Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); ! end if; Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result = 0 then ! Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, ! Cond_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); end if; if Result = 0 then Succeeded := True; else ! if not Single_Lock then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; ! Succeeded := False; end if; *************** package body System.Task_Primitives.Oper *** 723,728 **** --- 663,669 ---- (System.Task_Info.Resource_Vector_T, System.OS_Interface.resource_t); use System.Task_Info; + begin if Stack_Size = Unspecified_Size then Adjusted_Stack_Size := *************** package body System.Task_Primitives.Oper *** 809,816 **** Tmp : Task_ID := T; begin ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); --- 750,760 ---- Tmp : Task_ID := T; begin ! if not Single_Lock then ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; ! Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 836,842 **** 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)); --- 780,785 ---- *************** package body System.Task_Primitives.Oper *** 873,895 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 816,838 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 929,935 **** begin Environment_Task_ID := Environment_Task; ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); -- Initialize the lock used to synchronize chain of all ATCBs. Enter_Task (Environment_Task); --- 872,878 ---- 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); diff -Nrc3pad gcc-3.2.3/gcc/ada/5gtasinf.adb gcc-3.3/gcc/ada/5gtasinf.adb *** gcc-3.2.3/gcc/ada/5gtasinf.adb 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/5gtasinf.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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- -- *************** with Interfaces.C; *** 42,47 **** --- 41,47 ---- with System.OS_Interface; with System; with Unchecked_Conversion; + package body System.Task_Info is use System.OS_Interface; *************** package body System.Task_Info is *** 67,118 **** TXTLOCK => 2, DATLOCK => 4); package body Resource_Vector_Functions is ! function "+" (R : Resource_T) ! return Resource_Vector_T is Result : Resource_Vector_T := NO_RESOURCES; begin Result (Resource_T'Pos (R)) := True; return Result; end "+"; ! function "+" (R1, R2 : Resource_T) ! return Resource_Vector_T is Result : Resource_Vector_T := NO_RESOURCES; begin Result (Resource_T'Pos (R1)) := True; Result (Resource_T'Pos (R2)) := True; return Result; end "+"; ! function "+" (R : Resource_T; S : Resource_Vector_T) ! return Resource_Vector_T is Result : Resource_Vector_T := S; begin Result (Resource_T'Pos (R)) := True; return Result; end "+"; ! function "+" (S : Resource_Vector_T; R : Resource_T) ! return Resource_Vector_T is Result : Resource_Vector_T := S; begin Result (Resource_T'Pos (R)) := True; return Result; end "+"; ! function "+" (S1, S2 : Resource_Vector_T) ! return Resource_Vector_T is Result : Resource_Vector_T; begin Result := S1 or S2; return Result; end "+"; ! function "-" (S : Resource_Vector_T; R : Resource_T) ! return Resource_Vector_T is Result : Resource_Vector_T := S; begin Result (Resource_T'Pos (R)) := False; return Result; --- 67,138 ---- TXTLOCK => 2, DATLOCK => 4); + ------------------------------- + -- Resource_Vector_Functions -- + ------------------------------- + package body Resource_Vector_Functions is ! --------- ! -- "+" -- ! --------- ! ! function "+" (R : Resource_T) return Resource_Vector_T is Result : Resource_Vector_T := NO_RESOURCES; + begin Result (Resource_T'Pos (R)) := True; return Result; end "+"; ! function "+" (R1, R2 : Resource_T) return Resource_Vector_T is Result : Resource_Vector_T := NO_RESOURCES; + begin Result (Resource_T'Pos (R1)) := True; Result (Resource_T'Pos (R2)) := True; return Result; end "+"; ! function "+" ! (R : Resource_T; ! S : Resource_Vector_T) ! return Resource_Vector_T ! is Result : Resource_Vector_T := S; + begin Result (Resource_T'Pos (R)) := True; return Result; end "+"; ! function "+" ! (S : Resource_Vector_T; ! R : Resource_T) ! return Resource_Vector_T ! is Result : Resource_Vector_T := S; + begin Result (Resource_T'Pos (R)) := True; return Result; end "+"; ! function "+" (S1, S2 : Resource_Vector_T) return Resource_Vector_T is Result : Resource_Vector_T; + begin Result := S1 or S2; return Result; end "+"; ! function "-" ! (S : Resource_Vector_T; ! R : Resource_T) ! return Resource_Vector_T ! is Result : Resource_Vector_T := S; + begin Result (Resource_T'Pos (R)) := False; return Result; *************** package body System.Task_Info is *** 120,133 **** end Resource_Vector_Functions; function New_Sproc (Attr : Sproc_Attributes) return sproc_t is Sproc_Attr : aliased sproc_attr_t; Sproc : aliased sproc_t; Status : int; begin Status := sproc_attr_init (Sproc_Attr'Unrestricted_Access); - if Status = 0 then Status := sproc_attr_setresources (Sproc_Attr'Unrestricted_Access, To_Resource_T (Attr.Sproc_Resources)); --- 140,158 ---- end Resource_Vector_Functions; + --------------- + -- New_Sproc -- + --------------- + function New_Sproc (Attr : Sproc_Attributes) return sproc_t is Sproc_Attr : aliased sproc_attr_t; Sproc : aliased sproc_t; Status : int; + begin Status := sproc_attr_init (Sproc_Attr'Unrestricted_Access); + if Status = 0 then Status := sproc_attr_setresources (Sproc_Attr'Unrestricted_Access, To_Resource_T (Attr.Sproc_Resources)); *************** package body System.Task_Info is *** 136,148 **** if Attr.CPU > Num_Processors then raise Invalid_CPU_Number; end if; Status := sproc_attr_setcpu (Sproc_Attr'Unrestricted_Access, int (Attr.CPU)); end if; if Attr.Resident /= NOLOCK then - if Geteuid /= 0 then raise Permission_Error; end if; --- 161,173 ---- if Attr.CPU > Num_Processors then raise Invalid_CPU_Number; end if; + Status := sproc_attr_setcpu (Sproc_Attr'Unrestricted_Access, int (Attr.CPU)); end if; if Attr.Resident /= NOLOCK then if Geteuid /= 0 then raise Permission_Error; end if; *************** package body System.Task_Info is *** 153,158 **** --- 178,184 ---- end if; if Attr.NDPRI /= NDP_NONE then + -- ??? why is that comment out, should it be removed ? -- if Geteuid /= 0 then -- raise Permission_Error; -- end if; *************** package body System.Task_Info is *** 184,196 **** return Sproc; end New_Sproc; function New_Sproc (Sproc_Resources : Resource_Vector_T := NO_RESOURCES; CPU : CPU_Number := ANY_CPU; Resident : Page_Locking := NOLOCK; NDPRI : Non_Degrading_Priority := NDP_NONE) ! return sproc_t is ! Attr : Sproc_Attributes := (Sproc_Resources, CPU, Resident, NDPRI); --- 210,226 ---- return Sproc; end New_Sproc; + --------------- + -- New_Sproc -- + --------------- + function New_Sproc (Sproc_Resources : Resource_Vector_T := NO_RESOURCES; CPU : CPU_Number := ANY_CPU; Resident : Page_Locking := NOLOCK; NDPRI : Non_Degrading_Priority := NDP_NONE) ! return sproc_t ! is Attr : Sproc_Attributes := (Sproc_Resources, CPU, Resident, NDPRI); *************** package body System.Task_Info is *** 198,220 **** return New_Sproc (Attr); end New_Sproc; function Unbound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0) ! return Thread_Attributes is begin return (False, Thread_Resources, Thread_Timeslice); end Unbound_Thread_Attributes; function Bound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0; Sproc : sproc_t) ! return Thread_Attributes is begin return (True, Thread_Resources, Thread_Timeslice, Sproc); end Bound_Thread_Attributes; function Bound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0; --- 228,264 ---- return New_Sproc (Attr); end New_Sproc; + ------------------------------- + -- Unbound_Thread_Attributes -- + ------------------------------- + function Unbound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0) ! return Thread_Attributes ! is begin return (False, Thread_Resources, Thread_Timeslice); end Unbound_Thread_Attributes; + ----------------------------- + -- Bound_Thread_Attributes -- + ----------------------------- + function Bound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0; Sproc : sproc_t) ! return Thread_Attributes ! is begin return (True, Thread_Resources, Thread_Timeslice, Sproc); end Bound_Thread_Attributes; + ----------------------------- + -- Bound_Thread_Attributes -- + ----------------------------- + function Bound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0; *************** package body System.Task_Info is *** 222,229 **** CPU : CPU_Number := ANY_CPU; Resident : Page_Locking := NOLOCK; NDPRI : Non_Degrading_Priority := NDP_NONE) ! return Thread_Attributes is ! Sproc : sproc_t := New_Sproc (Sproc_Resources, CPU, Resident, NDPRI); --- 266,273 ---- CPU : CPU_Number := ANY_CPU; Resident : Page_Locking := NOLOCK; NDPRI : Non_Degrading_Priority := NDP_NONE) ! return Thread_Attributes ! is Sproc : sproc_t := New_Sproc (Sproc_Resources, CPU, Resident, NDPRI); *************** package body System.Task_Info is *** 231,255 **** return (True, Thread_Resources, Thread_Timeslice, Sproc); end Bound_Thread_Attributes; function New_Unbound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0) ! return Task_Info_Type is begin return new Thread_Attributes' (False, Thread_Resources, Thread_Timeslice); end New_Unbound_Thread_Attributes; function New_Bound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0; Sproc : sproc_t) ! return Task_Info_Type is begin return new Thread_Attributes' (True, Thread_Resources, Thread_Timeslice, Sproc); end New_Bound_Thread_Attributes; function New_Bound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0; --- 275,313 ---- return (True, Thread_Resources, Thread_Timeslice, Sproc); end Bound_Thread_Attributes; + ----------------------------------- + -- New_Unbound_Thread_Attributes -- + ----------------------------------- + function New_Unbound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0) ! return Task_Info_Type ! is begin return new Thread_Attributes' (False, Thread_Resources, Thread_Timeslice); end New_Unbound_Thread_Attributes; + --------------------------------- + -- New_Bound_Thread_Attributes -- + --------------------------------- + function New_Bound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0; Sproc : sproc_t) ! return Task_Info_Type ! is begin return new Thread_Attributes' (True, Thread_Resources, Thread_Timeslice, Sproc); end New_Bound_Thread_Attributes; + --------------------------------- + -- New_Bound_Thread_Attributes -- + --------------------------------- + function New_Bound_Thread_Attributes (Thread_Resources : Resource_Vector_T := NO_RESOURCES; Thread_Timeslice : Duration := 0.0; *************** package body System.Task_Info is *** 257,264 **** CPU : CPU_Number := ANY_CPU; Resident : Page_Locking := NOLOCK; NDPRI : Non_Degrading_Priority := NDP_NONE) ! return Task_Info_Type is ! Sproc : sproc_t := New_Sproc (Sproc_Resources, CPU, Resident, NDPRI); --- 315,322 ---- CPU : CPU_Number := ANY_CPU; Resident : Page_Locking := NOLOCK; NDPRI : Non_Degrading_Priority := NDP_NONE) ! return Task_Info_Type ! is Sproc : sproc_t := New_Sproc (Sproc_Resources, CPU, Resident, NDPRI); diff -Nrc3pad gcc-3.2.3/gcc/ada/5gtasinf.ads gcc-3.3/gcc/ada/5gtasinf.ads *** gcc-3.2.3/gcc/ada/5gtasinf.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5gtasinf.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** *** 40,45 **** --- 39,45 ---- with System.OS_Interface; with Unchecked_Deallocation; + package System.Task_Info is pragma Elaborate_Body; -- To ensure that a body is allowed *************** pragma Elaborate_Body; *** 49,58 **** --------------------------------------------------------- -- The SGI implementation of the GNU Low-Level Interface (GNULLI) ! -- implements each Ada task as a Posix thread (Pthread). The SGI -- Pthread library distributes threads across one or more processes ! -- that are members of a common share group. Irix distributes ! -- processes across the available CPUs on a given machine. The -- pragma Task_Info provides the mechanism to control the distribution -- of tasks to sprocs, and sprocs to processors. --- 49,58 ---- --------------------------------------------------------- -- The SGI implementation of the GNU Low-Level Interface (GNULLI) ! -- implements each Ada task as a Posix thread (Pthread). The SGI -- Pthread library distributes threads across one or more processes ! -- that are members of a common share group. Irix distributes ! -- processes across the available CPUs on a given machine. The -- pragma Task_Info provides the mechanism to control the distribution -- of tasks to sprocs, and sprocs to processors. *************** pragma Elaborate_Body; *** 103,121 **** NO_RESOURCES : constant Resource_Vector_T := (others => False); generic ! type Resource_T is (<>); -- Discrete type up to 32 entries package Resource_Vector_Functions is ! function "+"(R : Resource_T) return Resource_Vector_T; ! function "+"(R1, R2 : Resource_T) return Resource_Vector_T; ! function "+"(R : Resource_T; S : Resource_Vector_T) return Resource_Vector_T; ! function "+"(S : Resource_Vector_T; R : Resource_T) return Resource_Vector_T; ! function "+"(S1, S2 : Resource_Vector_T) return Resource_Vector_T; ! function "-"(S : Resource_Vector_T; R : Resource_T) return Resource_Vector_T; end Resource_Vector_Functions; --- 103,139 ---- NO_RESOURCES : constant Resource_Vector_T := (others => False); generic ! type Resource_T is (<>); ! -- Discrete type up to 32 entries ! package Resource_Vector_Functions is ! function "+" ! (R : Resource_T) return Resource_Vector_T; ! ! function "+" ! (R1 : Resource_T; ! R2 : Resource_T) return Resource_Vector_T; ! ! function "+" ! (R : Resource_T; ! S : Resource_Vector_T) return Resource_Vector_T; ! ! function "+" ! (S : Resource_Vector_T; ! R : Resource_T) return Resource_Vector_T; ! ! function "+" ! (S1 : Resource_Vector_T; ! S2 : Resource_Vector_T) return Resource_Vector_T; ! ! function "-" ! (S : Resource_Vector_T; ! R : Resource_T) return Resource_Vector_T; end Resource_Vector_Functions; *************** pragma Elaborate_Body; *** 129,135 **** ANY_CPU : constant CPU_Number := CPU_Number'First; ! -- -- Specification of IRIX Non Degrading Priorities. -- -- WARNING: IRIX priorities have the reverse meaning of Ada priorities. --- 147,153 ---- ANY_CPU : constant CPU_Number := CPU_Number'First; ! type Non_Degrading_Priority is range 0 .. 255; -- Specification of IRIX Non Degrading Priorities. -- -- WARNING: IRIX priorities have the reverse meaning of Ada priorities. *************** pragma Elaborate_Body; *** 138,161 **** -- -- See the schedctl(2) man page for a complete discussion of non-degrading -- priorities. - -- - type Non_Degrading_Priority is range 0 .. 255; ! -- these priorities are higher than ALL normal user process priorities ! NDPHIMAX : constant Non_Degrading_Priority := 30; ! NDPHIMIN : constant Non_Degrading_Priority := 39; subtype NDP_High is Non_Degrading_Priority range NDPHIMAX .. NDPHIMIN; - -- these priorities overlap normal user process priorities NDPNORMMAX : constant Non_Degrading_Priority := 40; NDPNORMMIN : constant Non_Degrading_Priority := 127; subtype NDP_Norm is Non_Degrading_Priority range NDPNORMMAX .. NDPNORMMIN; ! -- these priorities are below ALL normal user process priorities ! NDPLOMAX : constant Non_Degrading_Priority := 128; ! NDPLOMIN : constant Non_Degrading_Priority := 254; NDP_NONE : constant Non_Degrading_Priority := 255; --- 156,177 ---- -- -- See the schedctl(2) man page for a complete discussion of non-degrading -- priorities. ! NDPHIMAX : constant Non_Degrading_Priority := 30; ! NDPHIMIN : constant Non_Degrading_Priority := 39; ! -- These priorities are higher than ALL normal user process priorities subtype NDP_High is Non_Degrading_Priority range NDPHIMAX .. NDPHIMIN; NDPNORMMAX : constant Non_Degrading_Priority := 40; NDPNORMMIN : constant Non_Degrading_Priority := 127; + -- These priorities overlap normal user process priorities subtype NDP_Norm is Non_Degrading_Priority range NDPNORMMAX .. NDPNORMMIN; ! NDPLOMAX : constant Non_Degrading_Priority := 128; ! NDPLOMIN : constant Non_Degrading_Priority := 254; ! -- These priorities are below ALL normal user process priorities NDP_NONE : constant Non_Degrading_Priority := 255; *************** pragma Elaborate_Body; *** 168,184 **** DATLOCK -- Lock data segment into memory (data lock) ); ! type Sproc_Attributes is ! record ! Sproc_Resources : Resource_Vector_T := NO_RESOURCES; ! CPU : CPU_Number := ANY_CPU; ! Resident : Page_Locking := NOLOCK; ! NDPRI : Non_Degrading_Priority := NDP_NONE; -- Sproc_Slice : Duration := 0.0; -- Deadline_Period : Duration := 0.0; -- Deadline_Alloc : Duration := 0.0; ! ! end record; Default_Sproc_Attributes : constant Sproc_Attributes := (NO_RESOURCES, ANY_CPU, NOLOCK, NDP_NONE); --- 184,199 ---- DATLOCK -- Lock data segment into memory (data lock) ); ! type Sproc_Attributes is record ! Sproc_Resources : Resource_Vector_T := NO_RESOURCES; ! CPU : CPU_Number := ANY_CPU; ! Resident : Page_Locking := NOLOCK; ! NDPRI : Non_Degrading_Priority := NDP_NONE; ! -- ??? why is that commented out, should it be removed ? -- Sproc_Slice : Duration := 0.0; -- Deadline_Period : Duration := 0.0; -- Deadline_Alloc : Duration := 0.0; ! end record; Default_Sproc_Attributes : constant Sproc_Attributes := (NO_RESOURCES, ANY_CPU, NOLOCK, NDP_NONE); *************** pragma Elaborate_Body; *** 190,199 **** Resident : Page_Locking := NOLOCK; NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t; ! -- ! -- Allocates a sproc_t controll structure and creates the -- corresponding sproc. - -- Invalid_CPU_Number : exception; Permission_Error : exception; --- 205,212 ---- Resident : Page_Locking := NOLOCK; NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t; ! -- Allocates a sproc_t control structure and creates the -- corresponding sproc. Invalid_CPU_Number : exception; Permission_Error : exception; *************** pragma Elaborate_Body; *** 203,219 **** -- Thread Attributes -- ----------------------- ! type Thread_Attributes (Bound_To_Sproc : Boolean) is ! record ! Thread_Resources : Resource_Vector_T := NO_RESOURCES; ! Thread_Timeslice : Duration := 0.0; ! case Bound_To_Sproc is ! when False => ! null; ! when True => ! Sproc : sproc_t; ! end case; ! end record; Default_Thread_Attributes : constant Thread_Attributes := (False, NO_RESOURCES, 0.0); --- 216,233 ---- -- Thread Attributes -- ----------------------- ! type Thread_Attributes (Bound_To_Sproc : Boolean) is record ! Thread_Resources : Resource_Vector_T := NO_RESOURCES; ! ! Thread_Timeslice : Duration := 0.0; ! ! case Bound_To_Sproc is ! when False => ! null; ! when True => ! Sproc : sproc_t; ! end case; ! end record; Default_Thread_Attributes : constant Thread_Attributes := (False, NO_RESOURCES, 0.0); diff -Nrc3pad gcc-3.2.3/gcc/ada/5gtpgetc.adb gcc-3.3/gcc/ada/5gtpgetc.adb *** gcc-3.2.3/gcc/ada/5gtpgetc.adb 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5gtpgetc.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2000 Free Software Fundation -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5hosinte.adb gcc-3.3/gcc/ada/5hosinte.adb *** gcc-3.2.3/gcc/ada/5hosinte.adb 2001-10-02 13:42:26.000000000 +0000 --- gcc-3.3/gcc/ada/5hosinte.adb 2002-03-14 10:58:31.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2001, Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5hosinte.ads gcc-3.3/gcc/ada/5hosinte.ads *** gcc-3.2.3/gcc/ada/5hosinte.ads 2001-10-02 13:42:26.000000000 +0000 --- gcc-3.3/gcc/ada/5hosinte.ads 2002-03-14 10:58:31.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1997-2001, Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5hparame.ads gcc-3.3/gcc/ada/5hparame.ads *** gcc-3.2.3/gcc/ada/5hparame.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5hparame.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** *** 34,39 **** --- 33,39 ---- ------------------------------------------------------------------------------ -- This is the HP version of this package + -- 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 *************** pragma Pure (Parameters); *** 101,107 **** -- proper implementation of the stack overflow check. ---------------------------------------------- ! -- Characteristics of types in Interfaces.C -- ---------------------------------------------- long_bits : constant := Long_Integer'Size; --- 101,107 ---- -- proper implementation of the stack overflow check. ---------------------------------------------- ! -- Characteristics of Types in Interfaces.C -- ---------------------------------------------- long_bits : constant := Long_Integer'Size; *************** pragma Pure (Parameters); *** 132,135 **** --- 132,190 ---- 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 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); + + -------------------- + -- 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.2.3/gcc/ada/5hsystem.ads gcc-3.3/gcc/ada/5hsystem.ads *** gcc-3.2.3/gcc/ada/5hsystem.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5hsystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (HP-UX Version) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 92,118 **** -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 91,104 ---- -- 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 *************** private *** 130,137 **** --- 116,126 ---- -- 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 := 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5htaprop.adb gcc-3.3/gcc/ada/5htaprop.adb *** gcc-3.2.3/gcc/ada/5htaprop.adb 2001-12-16 01:13:27.000000000 +0000 --- gcc-3.3/gcc/ada/5htaprop.adb 2002-10-23 08:27:54.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 28,40 **** -- 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 -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. --- 27,38 ---- -- 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 DCE threads version of this package -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. *************** package body System.Task_Primitives.Oper *** 106,113 **** ATCB_Key : aliased pthread_key_t; -- Key used to find the Ada Task_ID associated with a thread ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 104,113 ---- 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. *************** package body System.Task_Primitives.Oper *** 143,195 **** -- 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 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 Self_Id : constant 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 --- 143,154 ---- *************** package body System.Task_Primitives.Oper *** 204,218 **** 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; ----------------- --- 163,168 ---- *************** package body System.Task_Primitives.Oper *** 243,249 **** function Self return Task_ID is Result : System.Address; - begin Result := pthread_getspecific (ATCB_Key); pragma Assert (Result /= System.Null_Address); --- 193,198 ---- *************** package body System.Task_Primitives.Oper *** 256,262 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as All_Tasks_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. --- 205,211 ---- -- 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. *************** package body System.Task_Primitives.Oper *** 266,272 **** 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); --- 215,222 ---- 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); *************** package body System.Task_Primitives.Oper *** 290,296 **** 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); --- 240,246 ---- 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); *************** package body System.Task_Primitives.Oper *** 318,324 **** procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L.L'Access); pragma Assert (Result = 0); --- 268,273 ---- *************** package body System.Task_Primitives.Oper *** 326,332 **** procedure Finalize_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); --- 275,280 ---- *************** package body System.Task_Primitives.Oper *** 337,344 **** ---------------- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is ! Result : Interfaces.C.int; ! begin L.Owner_Priority := Get_Priority (Self); --- 285,291 ---- ---------------- 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 *** 352,371 **** Ceiling_Violation := False; end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Write_Lock; --------------- --- 299,322 ---- Ceiling_Violation := False; end Write_Lock; ! procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) ! is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); ! end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Write_Lock; --------------- *************** package body System.Task_Primitives.Oper *** 382,422 **** ------------ procedure Unlock (L : access Lock) is ! Result : Interfaces.C.int; ! begin Result := pthread_mutex_unlock (L.L'Access); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Unlock; ! ------------- ! -- Sleep -- ! ------------- ! procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; - begin ! pragma Assert (Self_ID = Self); ! Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access); -- EINTR is not considered a failure. pragma Assert (Result = 0 or else Result = EINTR); end Sleep; --- 333,380 ---- ------------ procedure Unlock (L : access Lock) is ! Result : Interfaces.C.int; begin Result := pthread_mutex_unlock (L.L'Access); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); ! end if; end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Unlock; ! ----------- ! -- Sleep -- ! ----------- ! procedure Sleep ! (Self_ID : 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. pragma Assert (Result = 0 or else Result = EINTR); end Sleep; *************** package body System.Task_Primitives.Oper *** 425,434 **** -- 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; --- 383,388 ---- *************** package body System.Task_Primitives.Oper *** 441,446 **** --- 395,401 ---- Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; + begin Timedout := True; Yielded := False; *************** package body System.Task_Primitives.Oper *** 458,466 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level or else Self_ID.Pending_Priority_Change; ! Result := pthread_cond_timedwait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, ! Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 413,428 ---- 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; *************** package body System.Task_Primitives.Oper *** 479,488 **** -- 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; --- 441,446 ---- *************** package body System.Task_Primitives.Oper *** 492,504 **** Abs_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; Write_Lock (Self_ID); if Mode = Relative then --- 450,467 ---- Abs_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; + Write_Lock (Self_ID); if Mode = Relative then *************** package body System.Task_Primitives.Oper *** 520,527 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 483,495 ---- 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; *************** package body System.Task_Primitives.Oper *** 534,539 **** --- 502,512 ---- end if; Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + Result := sched_yield; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 567,573 **** 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); --- 540,545 ---- *************** package body System.Task_Primitives.Oper *** 579,585 **** procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; - begin if Do_Yield then Result := sched_yield; --- 551,556 ---- *************** package body System.Task_Primitives.Oper *** 681,695 **** Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); pragma Assert (Result = 0); ! Lock_All_Tasks_List; ! for I in Known_Tasks'Range loop ! if Known_Tasks (I) = null then ! Known_Tasks (I) := Self_ID; ! Self_ID.Known_Tasks_Index := I; exit; end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 652,668 ---- Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); pragma Assert (Result = 0); ! Lock_RTS; ! ! for J in Known_Tasks'Range loop ! if Known_Tasks (J) = null then ! Known_Tasks (J) := Self_ID; ! Self_ID.Known_Tasks_Index := J; exit; end if; end loop; ! ! Unlock_RTS; end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 701,755 **** 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 ! Result := pthread_mutexattr_init (Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; ! end if; ! Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, ! Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; end if; - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! Succeeded := False; ! return; end if; - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - if Result = 0 then Succeeded := True; else ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); Succeeded := False; end if; --- 674,725 ---- 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); ! 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; *************** package body System.Task_Primitives.Oper *** 834,841 **** Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); --- 804,814 ---- 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); *************** package body System.Task_Primitives.Oper *** 901,923 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 874,896 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 955,961 **** Environment_Task_ID := Environment_Task; ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); -- Initialize the lock used to synchronize chain of all ATCBs. Enter_Task (Environment_Task); --- 928,934 ---- 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); *************** package body System.Task_Primitives.Oper *** 985,991 **** end do_nothing; begin - declare Result : Interfaces.C.int; begin --- 958,963 ---- *************** begin *** 998,1002 **** Result := pthread_key_create (ATCB_Key'Access, do_nothing'Access); pragma Assert (Result = 0); end; - end System.Task_Primitives.Operations; --- 970,973 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5htaspri.ads gcc-3.3/gcc/ada/5htaspri.ads *** gcc-3.2.3/gcc/ada/5htaspri.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5htaspri.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5htraceb.adb gcc-3.3/gcc/ada/5htraceb.adb *** gcc-3.2.3/gcc/ada/5htraceb.adb 2001-10-02 13:42:26.000000000 +0000 --- gcc-3.3/gcc/ada/5htraceb.adb 2002-03-14 10:58:32.000000000 +0000 *************** *** 7,15 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- ! -- 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,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- -- *************** package body System.Traceback is *** 200,208 **** -- Descriptors. subtype UWT is Unwind_Table_Region; - type UWT_Ptr is access all UWT; - - function To_UWT_Address is new Ada.Unchecked_Conversion (UWT_Ptr, Address); -- The subprograms imported below are provided by the HP library --- 199,204 ---- *************** package body System.Traceback is *** 598,601 **** end Call_Chain; end System.Traceback; - --- 594,596 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5iosinte.adb gcc-3.3/gcc/ada/5iosinte.adb *** gcc-3.2.3/gcc/ada/5iosinte.adb 2001-10-04 17:50:42.000000000 +0000 --- gcc-3.3/gcc/ada/5iosinte.adb 2002-03-14 10:58:32.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5iosinte.ads gcc-3.3/gcc/ada/5iosinte.ads *** gcc-3.2.3/gcc/ada/5iosinte.ads 2002-05-04 03:27:14.000000000 +0000 --- gcc-3.3/gcc/ada/5iosinte.ads 2003-05-02 17:22:50.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package System.OS_Interface is *** 445,455 **** private ! type sigset_t is array (0 .. 31) of unsigned_long; pragma Convention (C, sigset_t); - for sigset_t'Size use 1024; - -- This is for GNU libc version 2 but should be backward compatible with - -- other libc where sigset_t is smaller. type pid_t is new int; --- 444,451 ---- private ! type sigset_t is array (0 .. 127) of unsigned_char; pragma Convention (C, sigset_t); type pid_t is new int; *************** private *** 478,484 **** stackaddr : System.Address; stacksize : size_t; end record; ! pragma Convention (C_Pass_By_Copy, pthread_attr_t); type pthread_condattr_t is record dummy : int; --- 474,480 ---- stackaddr : System.Address; stacksize : size_t; end record; ! pragma Convention (C, pthread_attr_t); type pthread_condattr_t is record dummy : int; *************** private *** 492,515 **** type pthread_t is new unsigned_long; ! type struct_pthread_queue is record ! head : System.Address; ! tail : System.Address; end record; ! pragma Convention (C, struct_pthread_queue); type pthread_mutex_t is record ! m_spinlock : int; m_count : int; m_owner : System.Address; m_kind : int; ! m_waiting : struct_pthread_queue; end record; pragma Convention (C, pthread_mutex_t); type pthread_cond_t is record ! c_spinlock : int; ! c_waiting : struct_pthread_queue; end record; pragma Convention (C, pthread_cond_t); --- 488,515 ---- type pthread_t is new unsigned_long; ! type struct_pthread_fast_lock is record ! status : long; ! spinlock : int; end record; ! pragma Convention (C, struct_pthread_fast_lock); type pthread_mutex_t is record ! m_reserved : int; m_count : int; m_owner : System.Address; m_kind : int; ! m_lock : struct_pthread_fast_lock; 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); diff -Nrc3pad gcc-3.2.3/gcc/ada/5itaprop.adb gcc-3.3/gcc/ada/5itaprop.adb *** gcc-3.2.3/gcc/ada/5itaprop.adb 2001-12-16 01:13:28.000000000 +0000 --- gcc-3.3/gcc/ada/5itaprop.adb 2002-03-14 10:58:33.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3 $ -- -- ! -- 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) 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- -- *************** *** 29,36 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- 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). -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 112,122 **** -- 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 ! ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 110,119 ---- -- The followings are logically constants, but need to be initialized -- at run time. ! Single_RTS_Lock : aliased RTS_Lock; ! -- This is a lock to allow only one thread of control in the RTS at ! -- a time; it is used to execute in mutual exclusion from all other tasks. ! -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 186,191 **** --- 183,211 ---- function To_pthread_t is new Unchecked_Conversion (Integer, System.OS_Interface.pthread_t); + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + 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. + ------------------- -- Abort_Handler -- ------------------- *************** package body System.Task_Primitives.Oper *** 297,305 **** end if; end Abort_Handler; ! ------------------- ! -- Stack_Guard -- ! ------------------- -- The underlying thread system extends the memory (up to 2MB) when -- needed. --- 317,343 ---- end if; end Abort_Handler; ! -------------- ! -- 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; ! ! ----------------- ! -- Stack_Guard -- ! ----------------- -- The underlying thread system extends the memory (up to 2MB) when -- needed. *************** package body System.Task_Primitives.Oper *** 322,335 **** -- 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 -- --- 360,366 ---- -- Self -- ---------- ! function Self return Task_ID renames Specific.Self; --------------------- -- Initialize_Lock -- *************** package body System.Task_Primitives.Oper *** 337,343 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as All_Tasks_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. --- 368,374 ---- -- 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. *************** package body System.Task_Primitives.Oper *** 401,407 **** procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; - begin if Priority_Ceiling_Emulation then declare --- 432,437 ---- *************** package body System.Task_Primitives.Oper *** 427,446 **** end if; end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Write_Lock; --------------- --- 457,480 ---- 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); ! 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; --------------- *************** package body System.Task_Primitives.Oper *** 458,464 **** procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin if Priority_Ceiling_Emulation then declare --- 492,497 ---- *************** package body System.Task_Primitives.Oper *** 476,514 **** end if; end Unlock; ! procedure Unlock (L : access RTS_Lock) is Result : Interfaces.C.int; - -- Beware of any changes to this that might - -- require access to the ATCB after the mutex is unlocked. - -- This is the last operation performed by a task - -- before it allows its ATCB to be deallocated, so it - -- MUST NOT refer to the ATCB. - begin ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Unlock; ! ------------- ! -- Sleep -- ! ------------- ! procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; - begin pragma Assert (Self_ID = Self); ! Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access); -- EINTR is not considered a failure. pragma Assert (Result = 0 or else Result = EINTR); end Sleep; --- 509,552 ---- 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 Result : Interfaces.C.int; begin pragma Assert (Self_ID = Self); ! ! 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; *************** package body System.Task_Primitives.Oper *** 550,558 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level or else Self_ID.Pending_Priority_Change; ! Result := pthread_cond_timedwait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, ! Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 588,603 ---- 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; *************** package body System.Task_Primitives.Oper *** 591,596 **** --- 636,646 ---- -- check for pending abort and priority change below! :( SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); if Mode = Relative then *************** package body System.Task_Primitives.Oper *** 612,619 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 662,674 ---- 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; *************** package body System.Task_Primitives.Oper *** 626,631 **** --- 681,691 ---- end if; Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + Result := sched_yield; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 734,756 **** ---------------- 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_All_Tasks_List; ! for I in Known_Tasks'Range loop ! if Known_Tasks (I) = null then ! Known_Tasks (I) := Self_ID; ! Self_ID.Known_Tasks_Index := I; exit; end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 794,815 ---- ---------------- procedure Enter_Task (Self_ID : Task_ID) is begin Self_ID.Common.LL.Thread := pthread_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; -------------- *************** package body System.Task_Primitives.Oper *** 778,790 **** Self_ID.Common.LL.Thread := To_pthread_t (-1); ! Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, ! Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; end if; Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, --- 837,851 ---- Self_ID.Common.LL.Thread := To_pthread_t (-1); ! if not Single_Lock then ! Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, ! Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; ! end if; end if; Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, *************** package body System.Task_Primitives.Oper *** 794,806 **** if Result = 0 then Succeeded := True; else ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); Succeeded := False; end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); end Initialize_TCB; ----------------- --- 855,867 ---- 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; end Initialize_TCB; ----------------- *************** package body System.Task_Primitives.Oper *** 865,877 **** Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; end if; Free (Tmp); end Finalize_TCB; --- 926,943 ---- 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); end Finalize_TCB; *************** package body System.Task_Primitives.Oper *** 927,950 **** return Environment_Task_ID; end Environment_Task; - ------------------------- - -- Lock_All_Tasks_List -- - ------------------------- - - procedure Lock_All_Tasks_List is - begin - Write_Lock (All_Tasks_L'Access); - end Lock_All_Tasks_List; - - --------------------------- - -- Unlock_All_Tasks_List -- - --------------------------- - - procedure Unlock_All_Tasks_List is - begin - Unlock (All_Tasks_L'Access); - end Unlock_All_Tasks_List; - ------------------ -- Suspend_Task -- ------------------ --- 993,998 ---- *************** package body System.Task_Primitives.Oper *** 994,1001 **** Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); ! -- Initialize the lock used to synchronize chain of all ATCBs. Enter_Task (Environment_Task); --- 1042,1051 ---- Result := pthread_condattr_init (Cond_Attr'Access); 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); Enter_Task (Environment_Task); *************** begin *** 1038,1046 **** pragma Assert (Result = 0); end if; end loop; - - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0); end; - end System.Task_Primitives.Operations; --- 1088,1092 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5itaspri.ads gcc-3.3/gcc/ada/5itaspri.ads *** gcc-3.2.3/gcc/ada/5itaspri.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5itaspri.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5ksystem.ads gcc-3.3/gcc/ada/5ksystem.ads *** gcc-3.2.3/gcc/ada/5ksystem.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5ksystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (VxWorks version M68K) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 88,127 **** -- Other System-Dependent Declarations type Bit_Order is (High_Order_First, Low_Order_First); ! Default_Bit_Order : constant Bit_Order := ! Bit_Order'Val (Standard'Default_Bit_Order); -- 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 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 87,112 ---- -- 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 *************** private *** 139,146 **** --- 124,134 ---- -- 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; 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5kvxwork.ads gcc-3.3/gcc/ada/5kvxwork.ads *** gcc-3.2.3/gcc/ada/5kvxwork.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5kvxwork.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1998-2001 Free Software Foundation -- -- -- -- GNARL is 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) 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- -- *************** package System.VxWorks is *** 42,71 **** package IC renames Interfaces.C; ! -- Define enough of a Wind Task Control Block in order to ! -- obtain the inherited priority. When porting this to ! -- different versions of VxWorks (this is based on 5.3[.1]), ! -- be sure to look at the definition for WIND_TCB located ! -- in $WIND_BASE/target/h/taskLib.h ! ! type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char; ! type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char; ! ! type Wind_TCB is record ! Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f ! Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority ! Normal_Priority : IC.int; -- 0x44 - 0x47, base priority ! Fill_2 : Wind_Fill_2; -- 0x48 - 0x107 ! spare1 : Address; -- 0x108 - 0x10b ! spare2 : Address; -- 0x10c - 0x10f ! spare3 : Address; -- 0x110 - 0x113 ! spare4 : Address; -- 0x114 - 0x117 ! end record; ! type Wind_TCB_Ptr is access Wind_TCB; ! ! -- Floating point context record. 68K version ! FP_NUM_DREGS : constant := 8; FP_STATE_FRAME_SIZE : constant := 216; type DOUBLEX is array (1 .. 12) of Interfaces.Unsigned_8; --- 41,49 ---- package IC renames Interfaces.C; ! -- Floating point context record. 68K version ! FP_NUM_DREGS : constant := 8; FP_STATE_FRAME_SIZE : constant := 216; type DOUBLEX is array (1 .. 12) of Interfaces.Unsigned_8; *************** package System.VxWorks is *** 96,120 **** Num_HW_Interrupts : constant := 256; -- Number of entries in the hardware interrupt vector table - -- VxWorks 5.3 and 5.4 version - type TASK_DESC is record - td_id : IC.int; -- task id - td_name : Address; -- name of task - td_priority : IC.int; -- task priority - td_status : IC.int; -- task status - td_options : IC.int; -- task option bits (see below) - td_entry : Address; -- original entry point of task - td_sp : Address; -- saved stack pointer - td_pStackBase : Address; -- the bottom of the stack - td_pStackLimit : Address; -- the effective end of the stack - td_pStackEnd : Address; -- the actual end of the stack - td_stackSize : IC.int; -- size of stack in bytes - td_stackCurrent : IC.int; -- current stack usage in bytes - td_stackHigh : IC.int; -- maximum stack usage in bytes - td_stackMargin : IC.int; -- current stack margin in bytes - td_errorStatus : IC.int; -- most recent task error status - td_delay : IC.int; -- delay/timeout ticks - end record; - pragma Convention (C, TASK_DESC); - end System.VxWorks; --- 74,77 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5lintman.adb gcc-3.3/gcc/ada/5lintman.adb *** gcc-3.2.3/gcc/ada/5lintman.adb 2001-12-16 01:13:28.000000000 +0000 --- gcc-3.3/gcc/ada/5lintman.adb 2002-03-14 10:58:34.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3 $ -- -- ! -- 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-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- -- *************** begin *** 304,336 **** act.sa_mask := Signal_Mask; ! Result := ! sigaction ! (Signal (SIGFPE), act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! ! for J in Exception_Interrupts'First + 1 .. Exception_Interrupts'Last loop Keep_Unmasked (Exception_Interrupts (J)) := True; ! if Unreserve_All_Interrupts = 0 then ! Result := ! sigaction ! (Signal (Exception_Interrupts (J)), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; end loop; Keep_Unmasked (Abort_Task_Interrupt) := True; - Keep_Unmasked (SIGXCPU) := True; - Keep_Unmasked (SIGBUS) := True; - Keep_Unmasked (SIGFPE) := 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 --- 303,324 ---- 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 diff -Nrc3pad gcc-3.2.3/gcc/ada/5lml-tgt.adb gcc-3.3/gcc/ada/5lml-tgt.adb *** gcc-3.2.3/gcc/ada/5lml-tgt.adb 2001-10-04 17:50:42.000000000 +0000 --- gcc-3.3/gcc/ada/5lml-tgt.adb 2002-03-14 10:58:34.000000000 +0000 *************** *** 7,13 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 2001, Ada Core Technologies, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5losinte.ads gcc-3.3/gcc/ada/5losinte.ads *** gcc-3.2.3/gcc/ada/5losinte.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5losinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5lsystem.ads gcc-3.3/gcc/ada/5lsystem.ads *** gcc-3.2.3/gcc/ada/5lsystem.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5lsystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 5,15 **** -- S Y S T E M -- -- -- -- S p e c -- ! -- (GNU/Linux/x86 Version) -- -- -- - -- $Revision: 1.2.12.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 5,14 ---- -- S Y S T E M -- -- -- -- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 88,119 **** -- Other System-Dependent Declarations type Bit_Order is (High_Order_First, Low_Order_First); ! Default_Bit_Order : constant Bit_Order := ! Bit_Order'Val (Standard'Default_Bit_Order); -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 87,104 ---- -- 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 *************** private *** 131,138 **** --- 116,126 ---- -- 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; *************** private *** 146,150 **** 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; --- 134,138 ---- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5mosinte.ads gcc-3.3/gcc/ada/5mosinte.ads *** gcc-3.2.3/gcc/ada/5mosinte.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5mosinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5mvxwork.ads gcc-3.3/gcc/ada/5mvxwork.ads *** gcc-3.2.3/gcc/ada/5mvxwork.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5mvxwork.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1998-2001 Free Software Foundation -- -- -- -- GNARL is 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) 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- -- *************** package System.VxWorks is *** 42,102 **** package IC renames Interfaces.C; ! -- Define enough of a Wind Task Control Block in order to ! -- obtain the inherited priority. When porting this to ! -- different versions of VxWorks (this is based on 5.3[.1]), ! -- be sure to look at the definition for WIND_TCB located ! -- in $WIND_BASE/target/h/taskLib.h ! ! type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char; ! type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char; ! ! type Wind_TCB is record ! Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f ! Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority ! Normal_Priority : IC.int; -- 0x44 - 0x47, base priority ! Fill_2 : Wind_Fill_2; -- 0x48 - 0x107 ! spare1 : Address; -- 0x108 - 0x10b ! spare2 : Address; -- 0x10c - 0x10f ! spare3 : Address; -- 0x110 - 0x113 ! spare4 : Address; -- 0x114 - 0x117 ! end record; ! type Wind_TCB_Ptr is access Wind_TCB; ! ! -- Floating point context record. MIPS version FP_NUM_DREGS : constant := 16; type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; type FP_CONTEXT is record ! fpx : Fpx_Array; fpcsr : IC.int; end record; pragma Convention (C, FP_CONTEXT); ! -- Number of entries in hardware interrupt vector table. Value of ! -- 0 disables hardware interrupt handling until it can be tested ! Num_HW_Interrupts : constant := 0; ! ! -- VxWorks 5.3 and 5.4 version ! type TASK_DESC is record ! td_id : IC.int; -- task id ! td_name : Address; -- name of task ! td_priority : IC.int; -- task priority ! td_status : IC.int; -- task status ! td_options : IC.int; -- task option bits (see below) ! td_entry : Address; -- original entry point of task ! td_sp : Address; -- saved stack pointer ! td_pStackBase : Address; -- the bottom of the stack ! td_pStackLimit : Address; -- the effective end of the stack ! td_pStackEnd : Address; -- the actual end of the stack ! td_stackSize : IC.int; -- size of stack in bytes ! td_stackCurrent : IC.int; -- current stack usage in bytes ! td_stackHigh : IC.int; -- maximum stack usage in bytes ! td_stackMargin : IC.int; -- current stack margin in bytes ! td_errorStatus : IC.int; -- most recent task error status ! td_delay : IC.int; -- delay/timeout ticks ! end record; ! pragma Convention (C, TASK_DESC); end System.VxWorks; --- 41,58 ---- package IC renames Interfaces.C; ! -- Floating point context record. MIPS version FP_NUM_DREGS : constant := 16; type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; type FP_CONTEXT is record ! fpx : Fpx_Array; fpcsr : IC.int; end record; 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.2.3/gcc/ada/5ninmaop.adb gcc-3.3/gcc/ada/5ninmaop.adb *** gcc-3.2.3/gcc/ada/5ninmaop.adb 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/5ninmaop.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 2,15 **** -- -- -- 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 . -- ! -- O P E R A T I O N S -- -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1992-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- -- --- 2,13 ---- -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- -- -- -- 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- -- *************** *** 38,43 **** --- 36,45 ---- package body System.Interrupt_Management.Operations is + -- Turn off warnings since many unused formals + + pragma Warnings (Off); + ---------------------------- -- Thread_Block_Interrupt -- ---------------------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/5nintman.adb gcc-3.3/gcc/ada/5nintman.adb *** gcc-3.2.3/gcc/ada/5nintman.adb 2002-05-07 08:22:02.000000000 +0000 --- gcc-3.3/gcc/ada/5nintman.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1991-1996, 1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5nosinte.ads gcc-3.3/gcc/ada/5nosinte.ads *** gcc-3.2.3/gcc/ada/5nosinte.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5nosinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.8.1 $ -- -- ! -- 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,13 ---- -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 35,52 **** -- This is the no tasking version - with Interfaces.C; package System.OS_Interface is pragma Preelaborate; - subtype int is Interfaces.C.int; - ------------- -- Signals -- ------------- Max_Interrupt : constant := 2; ! type Signal is new int range 0 .. Max_Interrupt; type sigset_t is new Integer; type Thread_Id is new Integer; --- 34,48 ---- -- This is the no tasking version package System.OS_Interface is pragma Preelaborate; ------------- -- Signals -- ------------- Max_Interrupt : constant := 2; ! type Signal is new Integer range 0 .. Max_Interrupt; type sigset_t is new Integer; type Thread_Id is new Integer; diff -Nrc3pad gcc-3.2.3/gcc/ada/5ntaprop.adb gcc-3.3/gcc/ada/5ntaprop.adb *** gcc-3.2.3/gcc/ada/5ntaprop.adb 2001-10-02 13:42:26.000000000 +0000 --- gcc-3.3/gcc/ada/5ntaprop.adb 2002-05-31 19:27:59.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- ! -- 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) 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- -- *************** *** 29,36 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- 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). -- -- -- ------------------------------------------------------------------------------ *************** with System.Tasking; *** 47,55 **** -- used for Ada_Task_Control_Block -- Task_ID - with System.OS_Primitives; - -- used for Delay_Modes - with System.Error_Reporting; -- used for Shutdown --- 45,50 ---- *************** package body System.Task_Primitives.Oper *** 57,67 **** use System.Tasking; use System.Parameters; - use System.OS_Primitives; ! ------------------- ! -- Stack_Guard -- ! ------------------- procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is begin --- 52,61 ---- use System.Tasking; use System.Parameters; ! ----------------- ! -- Stack_Guard -- ! ----------------- procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is begin *************** package body System.Task_Primitives.Oper *** 92,99 **** procedure Initialize_Lock (Prio : System.Any_Priority; ! L : access Lock) ! is begin null; end Initialize_Lock; --- 86,92 ---- procedure Initialize_Lock (Prio : System.Any_Priority; ! L : access Lock) is begin null; end Initialize_Lock; *************** package body System.Task_Primitives.Oper *** 126,132 **** Ceiling_Violation := False; end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is begin null; end Write_Lock; --- 119,127 ---- Ceiling_Violation := False; end Write_Lock; ! procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) ! is begin null; end Write_Lock; *************** package body System.Task_Primitives.Oper *** 154,160 **** null; end Unlock; ! procedure Unlock (L : access RTS_Lock) is begin null; end Unlock; --- 149,155 ---- null; end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is begin null; end Unlock; *************** package body System.Task_Primitives.Oper *** 164,175 **** null; end Unlock; ! ------------- ! -- Sleep -- ! ------------- ! procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) is begin null; end Sleep; --- 159,169 ---- null; end Unlock; ! ----------- ! -- Sleep -- ! ----------- ! procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is begin null; end Sleep; *************** package body System.Task_Primitives.Oper *** 195,219 **** ----------------- procedure Timed_Delay ! (Self_ID : Task_ID; ! Time : Duration; ! Mode : ST.Delay_Modes) ! is ! Rel_Time : Duration; ! ! procedure sleep (How_Long : Natural); ! pragma Import (C, sleep, "sleep"); ! begin ! if Mode = Relative then ! Rel_Time := Time; ! else ! Rel_Time := Time - Monotonic_Clock; ! end if; ! ! if Rel_Time > 0.0 then ! sleep (Natural (Rel_Time)); ! end if; end Timed_Delay; --------------------- --- 189,199 ---- ----------------- procedure Timed_Delay ! (Self_ID : Task_ID; ! Time : Duration; ! Mode : ST.Delay_Modes) is begin ! null; end Timed_Delay; --------------------- *************** package body System.Task_Primitives.Oper *** 248,255 **** ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is begin null; --- 228,235 ---- ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is begin null; *************** package body System.Task_Primitives.Oper *** 300,307 **** Wrapper : System.Address; Stack_Size : System.Parameters.Size_Type; Priority : System.Any_Priority; ! Succeeded : out Boolean) ! is begin Succeeded := False; end Create_Task; --- 280,286 ---- Wrapper : System.Address; Stack_Size : System.Parameters.Size_Type; Priority : System.Any_Priority; ! Succeeded : out Boolean) is begin Succeeded := False; end Create_Task; *************** package body System.Task_Primitives.Oper *** 372,394 **** return null; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin null; ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin null; ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 351,373 ---- return null; end Environment_Task; ! -------------- ! -- Lock_RTS -- ! -------------- ! procedure Lock_RTS is begin null; ! end Lock_RTS; ! ---------------- ! -- Unlock_RTS -- ! ---------------- ! procedure Unlock_RTS is begin null; ! end Unlock_RTS; ------------------ -- Suspend_Task -- *************** package body System.Task_Primitives.Oper *** 424,430 **** No_Tasking : Boolean; begin - -- Can't raise an exception because target independent packages try to -- do an Abort_Defer, which gets a memory fault. --- 403,408 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5ntaspri.ads gcc-3.3/gcc/ada/5ntaspri.ads *** gcc-3.2.3/gcc/ada/5ntaspri.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5ntaspri.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5ointerr.adb gcc-3.3/gcc/ada/5ointerr.adb *** gcc-3.2.3/gcc/ada/5ointerr.adb 2001-10-02 13:42:26.000000000 +0000 --- gcc-3.3/gcc/ada/5ointerr.adb 2002-03-14 10:58:35.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- ! -- 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-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- -- *************** with Ada.Exceptions; *** 43,48 **** --- 42,49 ---- package body System.Interrupts is + pragma Warnings (Off); -- kill warnings on unreferenced formals + use System.Tasking; ----------------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/5omastop.adb gcc-3.3/gcc/ada/5omastop.adb *** gcc-3.2.3/gcc/ada/5omastop.adb 2001-12-16 01:13:28.000000000 +0000 --- gcc-3.3/gcc/ada/5omastop.adb 2002-03-14 10:58:35.000000000 +0000 *************** *** 7,15 **** -- B o d y -- -- (Version for x86) -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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,14 ---- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 41,46 **** --- 40,46 ---- with Unchecked_Conversion; with System.Storage_Elements; with System.Machine_Code; use System.Machine_Code; + with System.Memory; package body System.Machine_State_Operations is *************** package body System.Machine_State_Operat *** 54,64 **** function To_Address is new Unchecked_Conversion (Uns32, Address); - function To_Uns32 is new Unchecked_Conversion (Integer, Uns32); - function To_Uns32 is new Unchecked_Conversion (Address, Uns32); - type Uns32_Ptr is access all Uns32; - function To_Uns32_Ptr is new Unchecked_Conversion (Address, Uns32_Ptr); function To_Uns32_Ptr is new Unchecked_Conversion (Uns32, Uns32_Ptr); -- Note: the type Uns32 has an alignment of 4. However, in some cases --- 54,60 ---- *************** package body System.Machine_State_Operat *** 178,186 **** --- 174,185 ---- Op_Immed : constant Bits6 := 2#100000#; Op2_addl_Immed : constant Bits5 := 2#11100#; + pragma Unreferenced (Op2_addl_Immed); + Op2_subl_Immed : constant Bits5 := 2#11101#; type Word_Byte is (Word, Byte); + pragma Unreferenced (Byte); type Ins_addl_subl_byte is record Op : Bits6; -- Set to Op_Immed *************** package body System.Machine_State_Operat *** 329,342 **** ---------------------------- function Allocate_Machine_State return Machine_State is - use System.Storage_Elements; - function Gnat_Malloc (Size : Storage_Offset) return Machine_State; - pragma Import (C, Gnat_Malloc, "__gnat_malloc"); - begin ! return Gnat_Malloc (MState'Max_Size_In_Storage_Elements); end Allocate_Machine_State; -------------------- --- 328,338 ---- ---------------------------- function Allocate_Machine_State return Machine_State is use System.Storage_Elements; begin ! return Machine_State ! (Memory.Alloc (MState'Max_Size_In_Storage_Elements)); end Allocate_Machine_State; -------------------- *************** package body System.Machine_State_Operat *** 445,455 **** ------------------------ procedure Free_Machine_State (M : in out Machine_State) is - procedure Gnat_Free (M : in Machine_State); - pragma Import (C, Gnat_Free, "__gnat_free"); - begin ! Gnat_Free (M); M := Machine_State (Null_Address); end Free_Machine_State; --- 441,448 ---- ------------------------ procedure Free_Machine_State (M : in out Machine_State) is begin ! Memory.Free (Address (M)); M := Machine_State (Null_Address); end Free_Machine_State; *************** package body System.Machine_State_Operat *** 584,590 **** procedure Set_Signal_Machine_State (M : Machine_State; ! Context : System.Address) is begin null; end Set_Signal_Machine_State; --- 577,587 ---- 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.2.3/gcc/ada/5oosinte.adb gcc-3.3/gcc/ada/5oosinte.adb *** gcc-3.2.3/gcc/ada/5oosinte.adb 2001-12-16 01:13:28.000000000 +0000 --- gcc-3.3/gcc/ada/5oosinte.adb 2002-03-14 10:58:35.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.4 $ -- -- ! -- 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-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- -- *************** pragma Polling (Off); *** 40,46 **** -- 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.Strings; with Interfaces.OS2Lib.Errors; with Interfaces.OS2Lib.Synchronization; --- 39,44 ---- *************** package body System.OS_Interface is *** 51,83 **** use Interfaces.OS2Lib.Synchronization; use Interfaces.OS2Lib.Errors; - ------------------ - -- Timer (spec) -- - ------------------ - - -- Although the OS uses a 32-bit integer representing milliseconds - -- as timer value that doesn't work for us since 32 bits are not - -- enough for absolute timing. Also it is useful to use better - -- intermediate precision when adding/subtracting timing intervals. - -- So we use the standard Ada Duration type which is implemented using - -- microseconds. - - -- Shouldn't the timer be moved to a separate package ??? - - type Timer is record - Handle : aliased HTIMER := NULLHANDLE; - Event : aliased HEV := NULLHANDLE; - end record; - - procedure Initialize (T : out Timer); - procedure Finalize (T : in out Timer); - procedure Wait (T : in out Timer); - procedure Reset (T : in out Timer); - - procedure Set_Timer_For (T : in out Timer; Period : in Duration); - procedure Set_Timer_At (T : in out Timer; Time : in Duration); - -- Add a hook to locate the Epoch, for use with Calendar???? - ----------- -- Yield -- ----------- --- 49,54 ---- *************** package body System.OS_Interface is *** 147,256 **** return Tick_Count * Tick_Duration; end Clock; - ---------------------- - -- Initialize Timer -- - ---------------------- - - procedure Initialize (T : out Timer) is - begin - pragma Assert - (T.Handle = NULLHANDLE, "GNULLI---Timer already initialized"); - - Must_Not_Fail (DosCreateEventSem - (pszName => Interfaces.C.Strings.Null_Ptr, - f_phev => T.Event'Unchecked_Access, - flAttr => DC_SEM_SHARED, - fState => False32)); - end Initialize; - - ------------------- - -- Set_Timer_For -- - ------------------- - - procedure Set_Timer_For - (T : in out Timer; - Period : in Duration) - is - Rel_Time : Duration_In_Millisec := - Duration_In_Millisec (Period * 1_000.0); - - begin - pragma Assert - (T.Event /= NULLHANDLE, "GNULLI---Timer not initialized"); - pragma Assert - (T.Handle = NULLHANDLE, "GNULLI---Timer already in use"); - - Must_Not_Fail (DosAsyncTimer - (msec => ULONG (Rel_Time), - F_hsem => HSEM (T.Event), - F_phtimer => T.Handle'Unchecked_Access)); - end Set_Timer_For; - - ------------------ - -- Set_Timer_At -- - ------------------ - - -- Note that the timer is started in a critical section to prevent the - -- race condition when absolute time is converted to time relative to - -- current time. T.Event will be posted when the Time has passed - - procedure Set_Timer_At - (T : in out Timer; - Time : in Duration) - is - Relative_Time : Duration; - - begin - Must_Not_Fail (DosEnterCritSec); - - begin - Relative_Time := Time - Clock; - if Relative_Time > 0.0 then - Set_Timer_For (T, Period => Time - Clock); - else - Sem_Must_Not_Fail (DosPostEventSem (T.Event)); - end if; - end; - - Must_Not_Fail (DosExitCritSec); - end Set_Timer_At; - - ---------- - -- Wait -- - ---------- - - procedure Wait (T : in out Timer) is - begin - Sem_Must_Not_Fail (DosWaitEventSem (T.Event, SEM_INDEFINITE_WAIT)); - T.Handle := NULLHANDLE; - end Wait; - - ----------- - -- Reset -- - ----------- - - procedure Reset (T : in out Timer) is - Dummy_Count : aliased ULONG; - - begin - if T.Handle /= NULLHANDLE then - Must_Not_Fail (DosStopTimer (T.Handle)); - T.Handle := NULLHANDLE; - end if; - - Sem_Must_Not_Fail - (DosResetEventSem (T.Event, Dummy_Count'Unchecked_Access)); - end Reset; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (T : in out Timer) is - begin - Reset (T); - Must_Not_Fail (DosCloseEventSem (T.Event)); - T.Event := NULLHANDLE; - end Finalize; - end System.OS_Interface; --- 118,121 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5oosinte.ads gcc-3.3/gcc/ada/5oosinte.ads *** gcc-3.2.3/gcc/ada/5oosinte.ads 2001-10-02 13:42:27.000000000 +0000 --- gcc-3.3/gcc/ada/5oosinte.ads 2002-03-14 10:58:35.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5oosprim.adb gcc-3.3/gcc/ada/5oosprim.adb *** gcc-3.2.3/gcc/ada/5oosprim.adb 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5oosprim.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5oparame.adb gcc-3.3/gcc/ada/5oparame.adb *** gcc-3.2.3/gcc/ada/5oparame.adb 2002-05-07 08:22:03.000000000 +0000 --- gcc-3.3/gcc/ada/5oparame.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1997-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5osystem.ads gcc-3.3/gcc/ada/5osystem.ads *** gcc-3.2.3/gcc/ada/5osystem.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5osystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (OS/2 Version) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 88,119 **** -- Other System-Dependent Declarations type Bit_Order is (High_Order_First, Low_Order_First); ! Default_Bit_Order : constant Bit_Order := ! Bit_Order'Val (Standard'Default_Bit_Order); -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 87,104 ---- -- 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 *************** private *** 131,138 **** --- 116,126 ---- -- 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; *************** private *** 146,151 **** 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; --- 134,139 ---- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5otaprop.adb gcc-3.3/gcc/ada/5otaprop.adb *** gcc-3.2.3/gcc/ada/5otaprop.adb 2001-12-16 01:13:28.000000000 +0000 --- gcc-3.3/gcc/ada/5otaprop.adb 2002-03-14 10:58:36.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 29,36 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- 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). -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 91,119 **** use Interfaces.OS2Lib.Errors; use Interfaces.OS2Lib.Threads; use Interfaces.OS2Lib.Synchronization; use System.Tasking.Debug; use System.Tasking; use System.OS_Interface; use Interfaces.C; use System.OS_Primitives; ! ---------------------- ! -- Local Constants -- ! ---------------------- Max_Locks_Per_Task : constant := 100; Suppress_Owner_Check : constant Boolean := False; ! ------------------ ! -- Local Types -- ! ------------------ - type Microseconds is new IC.long; subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task; ! ------------------ ! -- Local Data -- ! ------------------ -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr. --- 89,117 ---- use Interfaces.OS2Lib.Errors; use Interfaces.OS2Lib.Threads; use Interfaces.OS2Lib.Synchronization; + use System.Parameters; use System.Tasking.Debug; use System.Tasking; use System.OS_Interface; use Interfaces.C; use System.OS_Primitives; ! --------------------- ! -- Local Constants -- ! --------------------- Max_Locks_Per_Task : constant := 100; Suppress_Owner_Check : constant Boolean := False; ! ----------------- ! -- Local Types -- ! ----------------- subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task; ! ----------------- ! -- Local Data -- ! ----------------- -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr. *************** package body System.Task_Primitives.Oper *** 138,145 **** type PPTLD is access all Access_Thread_Local_Data; ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 136,145 ---- type PPTLD is access all Access_Thread_Local_Data; ! Single_RTS_Lock : aliased RTS_Lock; ! -- This is a lock to allow only one thread of control in the RTS at ! -- a time; it is used to execute in mutual exclusion from all other tasks. ! -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 192,206 **** -- handler or to change the execution context of the thread. -- So asynchonous transfer of control is not supported. ! ------------------- ! -- Stack_Guard -- ! ------------------- -- The underlying thread system sets a guard page at the -- bottom of a thread stack, so nothing is needed. -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is begin null; end Stack_Guard; --- 192,209 ---- -- handler or to change the execution context of the thread. -- So asynchonous transfer of control is not supported. ! ----------------- ! -- Stack_Guard -- ! ----------------- -- The underlying thread system sets a guard page at the -- bottom of a thread stack, so nothing is needed. -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Warnings (Off, T); + pragma Warnings (Off, On); + begin null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 220,226 **** function Self return Task_ID is Self_ID : Task_ID renames Thread_Local_Data_Ptr.Self_ID; - begin -- Check that the thread local data has been initialized. --- 223,228 ---- *************** package body System.Task_Primitives.Oper *** 252,257 **** --- 254,261 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Warnings (Off, Level); + begin if DosCreateMutexSem (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR *************** package body System.Task_Primitives.Oper *** 312,355 **** L.Owner_ID := Self_ID.all'Address; end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is ! Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID; ! Old_Priority : constant Any_Priority := ! Self_ID.Common.LL.Current_Priority; begin ! -- Increase priority before getting the lock ! -- to prevent priority inversion ! Thread_Local_Data_Ptr.Lock_Prio_Level := ! Thread_Local_Data_Ptr.Lock_Prio_Level + 1; ! if L.Priority > Old_Priority then ! Set_Temporary_Priority (Self_ID, L.Priority); ! end if; ! -- Request the lock and then update the lock owner data ! Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT)); ! L.Owner_Priority := Old_Priority; ! L.Owner_ID := Self_ID.all'Address; end Write_Lock; procedure Write_Lock (T : Task_ID) is begin ! -- Request the lock and then update the lock owner data ! Must_Not_Fail ! (DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT)); ! T.Common.LL.L.Owner_ID := Null_Address; end Write_Lock; --------------- -- Read_Lock -- --------------- ! procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) ! renames Write_Lock; ------------ -- Unlock -- --- 316,367 ---- L.Owner_ID := Self_ID.all'Address; end Write_Lock; ! procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) ! is ! Self_ID : Task_ID; ! Old_Priority : Any_Priority; begin ! if not Single_Lock or else Global_Lock then ! Self_ID := Thread_Local_Data_Ptr.Self_ID; ! Old_Priority := Self_ID.Common.LL.Current_Priority; ! -- Increase priority before getting the lock ! -- to prevent priority inversion ! Thread_Local_Data_Ptr.Lock_Prio_Level := ! Thread_Local_Data_Ptr.Lock_Prio_Level + 1; ! if L.Priority > Old_Priority then ! Set_Temporary_Priority (Self_ID, L.Priority); ! end if; ! -- Request the lock and then update the lock owner data ! ! Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT)); ! L.Owner_Priority := Old_Priority; ! L.Owner_ID := Self_ID.all'Address; ! end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is begin ! if not Single_Lock then ! -- Request the lock and then update the lock owner data ! Must_Not_Fail ! (DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT)); ! T.Common.LL.L.Owner_ID := Null_Address; ! end if; end Write_Lock; --------------- -- Read_Lock -- --------------- ! procedure Read_Lock ! (L : access Lock; Ceiling_Violation : out Boolean) renames Write_Lock; ------------ -- Unlock -- *************** package body System.Task_Primitives.Oper *** 383,435 **** end if; end Unlock; ! procedure Unlock (L : access RTS_Lock) is ! Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID; ! Old_Priority : constant Any_Priority := L.Owner_Priority; begin ! -- Check that this task holds the lock ! pragma Assert (Suppress_Owner_Check ! or else L.Owner_ID = Self_ID.all'Address); ! -- Upate the owner data ! L.Owner_ID := Null_Address; ! -- Do the actual unlocking. No more references ! -- to owner data of L after this point. ! Must_Not_Fail (DosReleaseMutexSem (L.Mutex)); ! -- Reset priority after unlocking to avoid priority inversion ! Thread_Local_Data_Ptr.Lock_Prio_Level := ! Thread_Local_Data_Ptr.Lock_Prio_Level - 1; ! if L.Priority /= Old_Priority then ! Set_Temporary_Priority (Self_ID, Old_Priority); end if; end Unlock; procedure Unlock (T : Task_ID) is begin ! -- Check the owner data ! pragma Assert (Suppress_Owner_Check ! or else T.Common.LL.L.Owner_ID = Null_Address); ! -- Do the actual unlocking. No more references ! -- to owner data of T.Common.LL.L after this point. ! Must_Not_Fail (DosReleaseMutexSem (T.Common.LL.L.Mutex)); end Unlock; ----------- -- Sleep -- ----------- ! procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) is Count : aliased ULONG; -- Used to store dummy result begin --- 395,457 ---- end if; end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is ! Self_ID : Task_ID; ! Old_Priority : Any_Priority; begin ! if not Single_Lock or else Global_Lock then ! Self_ID := Thread_Local_Data_Ptr.Self_ID; ! Old_Priority := L.Owner_Priority; ! -- Check that this task holds the lock ! pragma Assert (Suppress_Owner_Check ! or else L.Owner_ID = Self_ID.all'Address); ! -- Upate the owner data ! L.Owner_ID := Null_Address; ! -- Do the actual unlocking. No more references ! -- to owner data of L after this point. ! Must_Not_Fail (DosReleaseMutexSem (L.Mutex)); ! -- Reset priority after unlocking to avoid priority inversion ! Thread_Local_Data_Ptr.Lock_Prio_Level := ! Thread_Local_Data_Ptr.Lock_Prio_Level - 1; ! if L.Priority /= Old_Priority then ! Set_Temporary_Priority (Self_ID, Old_Priority); ! end if; end if; end Unlock; procedure Unlock (T : Task_ID) is begin ! if not Single_Lock then ! -- Check the owner data ! pragma Assert (Suppress_Owner_Check ! or else T.Common.LL.L.Owner_ID = Null_Address); ! -- Do the actual unlocking. No more references ! -- to owner data of T.Common.LL.L after this point. ! Must_Not_Fail (DosReleaseMutexSem (T.Common.LL.L.Mutex)); ! end if; end Unlock; ----------- -- Sleep -- ----------- ! procedure Sleep ! (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) ! is ! pragma Warnings (Off, Reason); ! Count : aliased ULONG; -- Used to store dummy result begin *************** package body System.Task_Primitives.Oper *** 437,443 **** Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); ! Unlock (Self_ID); -- No problem if we are interrupted here. -- If the condition is signaled, DosWaitEventSem will simply not block. --- 459,470 ---- Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); ! ! if Single_Lock then ! Unlock_RTS; ! else ! Unlock (Self_ID); ! end if; -- No problem if we are interrupted here. -- If the condition is signaled, DosWaitEventSem will simply not block. *************** package body System.Task_Primitives.Oper *** 447,453 **** -- Since L was previously accquired, lock operation should not fail. ! Write_Lock (Self_ID); end Sleep; ----------------- --- 474,484 ---- -- Since L was previously accquired, lock operation should not fail. ! if Single_Lock then ! Lock_RTS; ! else ! Write_Lock (Self_ID); ! end if; end Sleep; ----------------- *************** package body System.Task_Primitives.Oper *** 472,477 **** --- 503,510 ---- Timedout : out Boolean; Yielded : out Boolean) is + pragma Warnings (Off, Reason); + Check_Time : constant Duration := OSP.Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; *************** package body System.Task_Primitives.Oper *** 485,491 **** Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); ! Unlock (Self_ID); Timedout := True; Yielded := False; --- 518,529 ---- Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); ! ! if Single_Lock then ! Unlock_RTS; ! else ! Unlock (Self_ID); ! end if; Timedout := True; Yielded := False; *************** package body System.Task_Primitives.Oper *** 529,535 **** -- Ensure post-condition ! Write_Lock (Self_ID); if Timedout then Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); --- 567,577 ---- -- Ensure post-condition ! if Single_Lock then ! Lock_RTS; ! else ! Write_Lock (Self_ID); ! end if; if Timedout then Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); *************** package body System.Task_Primitives.Oper *** 550,556 **** Abs_Time : Duration; Timedout : Boolean := True; Time_Out : ULONG; ! Result : APIRET; Count : aliased ULONG; -- Used to store dummy result begin --- 592,598 ---- Abs_Time : Duration; Timedout : Boolean := True; Time_Out : ULONG; ! Result : APIRET; Count : aliased ULONG; -- Used to store dummy result begin *************** package body System.Task_Primitives.Oper *** 559,572 **** -- check for pending abort and priority change below! :( SSL.Abort_Defer.all; ! Write_Lock (Self_ID); -- Must reset Cond BEFORE Self_ID is unlocked. Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); ! Unlock (Self_ID); if Mode = Relative then Rel_Time := Time; --- 601,624 ---- -- check for pending abort and priority change below! :( SSL.Abort_Defer.all; ! ! if Single_Lock then ! Lock_RTS; ! else ! Write_Lock (Self_ID); ! end if; -- Must reset Cond BEFORE Self_ID is unlocked. Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); ! ! if Single_Lock then ! Unlock_RTS; ! else ! Unlock (Self_ID); ! end if; if Mode = Relative then Rel_Time := Time; *************** package body System.Task_Primitives.Oper *** 578,583 **** --- 630,636 ---- if Rel_Time > 0.0 then Self_ID.Common.State := Delay_Sleep; + loop if Self_ID.Pending_Priority_Change then Self_ID.Pending_Priority_Change := False; *************** package body System.Task_Primitives.Oper *** 599,613 **** Timedout := Result = ERROR_TIMEOUT; end if; ! -- Ensure post-condition ! ! Write_Lock (Self_ID); if Timedout then Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); end if; ! Unlock (Self_ID); System.OS_Interface.Yield; SSL.Abort_Undefer.all; end Timed_Delay; --- 652,673 ---- Timedout := Result = ERROR_TIMEOUT; end if; ! if Single_Lock then ! Lock_RTS; ! else ! Write_Lock (Self_ID); ! end if; if Timedout then Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); end if; ! if Single_Lock then ! Unlock_RTS; ! else ! Unlock (Self_ID); ! end if; ! System.OS_Interface.Yield; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 617,622 **** --- 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; *************** package body System.Task_Primitives.Oper *** 659,665 **** end if; if Delta_Priority /= 0 then - -- ??? There is a race-condition here -- The TCB is updated before the system call to make -- pre-emption in the critical section less likely. --- 720,725 ---- *************** package body System.Task_Primitives.Oper *** 679,687 **** ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; ! Loss_Of_Inheritance : Boolean := False) is begin T.Common.Current_Priority := Prio; Set_Temporary_Priority (T, Prio); --- 739,750 ---- ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; ! Loss_Of_Inheritance : Boolean := False) ! is ! pragma Warnings (Off, Loss_Of_Inheritance); ! begin T.Common.Current_Priority := Prio; Set_Temporary_Priority (T, Prio); *************** package body System.Task_Primitives.Oper *** 702,722 **** procedure Enter_Task (Self_ID : Task_ID) is begin - -- Initialize thread local data. Must be done first. Thread_Local_Data_Ptr.Self_ID := Self_ID; Thread_Local_Data_Ptr.Lock_Prio_Level := 0; ! Lock_All_Tasks_List; ! for I in Known_Tasks'Range loop ! if Known_Tasks (I) = null then ! Known_Tasks (I) := Self_ID; ! Self_ID.Known_Tasks_Index := I; exit; end if; end loop; ! Unlock_All_Tasks_List; -- For OS/2, we can set Self_ID.Common.LL.Thread in -- Create_Task, since the thread is created suspended. --- 765,786 ---- procedure Enter_Task (Self_ID : Task_ID) is begin -- Initialize thread local data. Must be done first. Thread_Local_Data_Ptr.Self_ID := Self_ID; Thread_Local_Data_Ptr.Lock_Prio_Level := 0; ! Lock_RTS; ! ! for J in Known_Tasks'Range loop ! if Known_Tasks (J) = null then ! Known_Tasks (J) := Self_ID; ! Self_ID.Known_Tasks_Index := J; exit; end if; end loop; ! ! Unlock_RTS; -- For OS/2, we can set Self_ID.Common.LL.Thread in -- Create_Task, since the thread is created suspended. *************** package body System.Task_Primitives.Oper *** 725,731 **** -- has been initialized. -- .... Do we need to do anything with signals for OS/2 ??? - null; end Enter_Task; -------------- --- 789,794 ---- *************** package body System.Task_Primitives.Oper *** 746,753 **** if DosCreateEventSem (ICS.Null_Ptr, Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR then ! if DosCreateMutexSem (ICS.Null_Ptr, ! Self_ID.Common.LL.L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR then Succeeded := False; Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV)); --- 809,820 ---- if DosCreateEventSem (ICS.Null_Ptr, Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR then ! if not Single_Lock ! and then DosCreateMutexSem ! (ICS.Null_Ptr, ! Self_ID.Common.LL.L.Mutex'Unchecked_Access, ! 0, ! False32) /= NO_ERROR then Succeeded := False; Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV)); *************** package body System.Task_Primitives.Oper *** 755,762 **** Succeeded := True; end if; - pragma Assert (Self_ID.Common.LL.L.Mutex /= 0); - -- We now want to do the equivalent of: -- Initialize_Lock --- 822,827 ---- *************** package body System.Task_Primitives.Oper *** 774,780 **** Succeeded := False; end if; ! -- Note: at one time we had anb exception handler here, whose code -- was as follows: -- exception --- 839,845 ---- Succeeded := False; end if; ! -- Note: at one time we had an exception handler here, whose code -- was as follows: -- exception *************** package body System.Task_Primitives.Oper *** 789,795 **** -- result in messing with Jmpbuf values too early. If and when we get -- switched entirely to the new zero-cost exception scheme, we could -- put this handler back in! - end Initialize_TCB; ----------------- --- 854,859 ---- *************** package body System.Task_Primitives.Oper *** 889,900 **** procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV)); ! Finalize_Lock (T.Common.LL.L'Unchecked_Access); if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; end if; Free (Tmp); end Finalize_TCB; --- 953,970 ---- procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + begin Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV)); ! ! if not Single_Lock then ! Finalize_Lock (T.Common.LL.L'Unchecked_Access); ! end if; ! if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; end if; + Free (Tmp); end Finalize_TCB; *************** package body System.Task_Primitives.Oper *** 916,921 **** --- 986,993 ---- ---------------- procedure Abort_Task (T : Task_ID) is + pragma Warnings (Off, T); + begin null; *************** package body System.Task_Primitives.Oper *** 956,978 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 1028,1050 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 1010,1020 **** procedure Initialize (Environment_Task : Task_ID) is Succeeded : Boolean; - begin Environment_Task_ID := Environment_Task; ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); -- Initialize the lock used to synchronize chain of all ATCBs. -- Set ID of environment task. --- 1082,1091 ---- procedure Initialize (Environment_Task : Task_ID) is Succeeded : Boolean; 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. -- Set ID of environment task. *************** package body System.Task_Primitives.Oper *** 1047,1053 **** -- Insert here any other special -- initialization needed for the environment task. - end Initialize; begin --- 1118,1123 ---- *************** begin *** 1062,1066 **** Thread_Local_Data_Ptr.Self_ID := null; Thread_Local_Data_Ptr.Lock_Prio_Level := 0; - end System.Task_Primitives.Operations; --- 1132,1135 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5otaspri.ads gcc-3.3/gcc/ada/5otaspri.ads *** gcc-3.2.3/gcc/ada/5otaspri.ads 2001-10-02 13:42:27.000000000 +0000 --- gcc-3.3/gcc/ada/5otaspri.ads 2002-03-14 10:58:36.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.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- -- --- 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- -- *************** package System.Task_Primitives is *** 69,81 **** -- private ! type Lock is ! record ! Mutex : aliased Interfaces.OS2Lib.Synchronization.HMTX; ! Priority : Integer; ! Owner_Priority : Integer; ! Owner_ID : Address; ! end record; type RTS_Lock is new Lock; --- 68,79 ---- -- private ! type Lock is record ! Mutex : aliased Interfaces.OS2Lib.Synchronization.HMTX; ! Priority : Integer; ! Owner_Priority : Integer; ! Owner_ID : Address; ! end record; type RTS_Lock is new Lock; diff -Nrc3pad gcc-3.2.3/gcc/ada/5posinte.ads gcc-3.3/gcc/ada/5posinte.ads *** gcc-3.2.3/gcc/ada/5posinte.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5posinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5posprim.adb gcc-3.3/gcc/ada/5posprim.adb *** gcc-3.2.3/gcc/ada/5posprim.adb 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5posprim.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5pvxwork.ads gcc-3.3/gcc/ada/5pvxwork.ads *** gcc-3.2.3/gcc/ada/5pvxwork.ads 2002-05-07 08:22:03.000000000 +0000 --- gcc-3.3/gcc/ada/5pvxwork.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1998 - 2001 Free Software Foundation -- -- -- -- GNARL is 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) 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- -- *************** *** 33,40 **** -- -- ------------------------------------------------------------------------------ ! -- This is the PPC VxWorks 5.x version of this package. A different version ! -- is used for VxWorks 6.0 with Interfaces.C; --- 32,38 ---- -- -- ------------------------------------------------------------------------------ ! -- This is the PPC VxWorks version of this package. with Interfaces.C; *************** package System.VxWorks is *** 43,102 **** package IC renames Interfaces.C; ! -- Define enough of a Wind Task Control Block in order to ! -- obtain the inherited priority. When porting this to ! -- different versions of VxWorks (this is based on 5.3[.1]), ! -- be sure to look at the definition for WIND_TCB located ! -- in $WIND_BASE/target/h/taskLib.h ! ! type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char; ! type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char; ! ! type Wind_TCB is record ! Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f ! Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority ! Normal_Priority : IC.int; -- 0x44 - 0x47, base priority ! Fill_2 : Wind_Fill_2; -- 0x48 - 0x107 ! spare1 : Address; -- 0x108 - 0x10b ! spare2 : Address; -- 0x10c - 0x10f ! spare3 : Address; -- 0x110 - 0x113 ! spare4 : Address; -- 0x114 - 0x117 ! end record; ! type Wind_TCB_Ptr is access Wind_TCB; ! ! -- Floating point context record. PPC version FP_NUM_DREGS : constant := 32; type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double; type FP_CONTEXT is record ! fpr : Fpr_Array; fpcsr : IC.int; ! pad : IC.int; end record; pragma Convention (C, FP_CONTEXT); Num_HW_Interrupts : constant := 256; - -- VxWorks 5.3 and 5.4 version - type TASK_DESC is record - td_id : IC.int; -- task id - td_name : Address; -- name of task - td_priority : IC.int; -- task priority - td_status : IC.int; -- task status - td_options : IC.int; -- task option bits (see below) - td_entry : Address; -- original entry point of task - td_sp : Address; -- saved stack pointer - td_pStackBase : Address; -- the bottom of the stack - td_pStackLimit : Address; -- the effective end of the stack - td_pStackEnd : Address; -- the actual end of the stack - td_stackSize : IC.int; -- size of stack in bytes - td_stackCurrent : IC.int; -- current stack usage in bytes - td_stackHigh : IC.int; -- maximum stack usage in bytes - td_stackMargin : IC.int; -- current stack margin in bytes - td_errorStatus : IC.int; -- most recent task error status - td_delay : IC.int; -- delay/timeout ticks - end record; - pragma Convention (C, TASK_DESC); - end System.VxWorks; --- 41,58 ---- package IC renames Interfaces.C; ! -- Floating point context record. PPC version FP_NUM_DREGS : constant := 32; type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double; type FP_CONTEXT is record ! fpr : Fpr_Array; fpcsr : IC.int; ! pad : IC.int; end record; pragma Convention (C, FP_CONTEXT); Num_HW_Interrupts : constant := 256; end System.VxWorks; diff -Nrc3pad gcc-3.2.3/gcc/ada/5qosinte.adb gcc-3.3/gcc/ada/5qosinte.adb *** gcc-3.2.3/gcc/ada/5qosinte.adb 2001-10-04 17:50:42.000000000 +0000 --- gcc-3.3/gcc/ada/5qosinte.adb 2002-03-14 10:58:37.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5qosinte.ads gcc-3.3/gcc/ada/5qosinte.ads *** gcc-3.2.3/gcc/ada/5qosinte.ads 2001-10-04 17:50:42.000000000 +0000 --- gcc-3.3/gcc/ada/5qosinte.ads 2002-03-14 10:58:37.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5qparame.ads gcc-3.3/gcc/ada/5qparame.ads *** gcc-3.2.3/gcc/ada/5qparame.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5qparame.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,136 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- S Y S T E M . P A R A M E T E R S -- - -- -- - -- S p e c -- - -- -- - -- $Revision: 1.2.12.1 $ - -- -- - -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- - -- -- - -- GNAT is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the RT-GNU/Linux version. - -- 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 := 10; - -- 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 - - 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) - - end System.Parameters; --- 0 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5qstache.adb gcc-3.3/gcc/ada/5qstache.adb *** gcc-3.2.3/gcc/ada/5qstache.adb 2001-10-02 13:42:27.000000000 +0000 --- gcc-3.3/gcc/ada/5qstache.adb 2002-03-14 10:58:37.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (Dummy version) -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000 Ada Core Technologies, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5qtaprop.adb gcc-3.3/gcc/ada/5qtaprop.adb *** gcc-3.2.3/gcc/ada/5qtaprop.adb 2001-10-04 17:50:42.000000000 +0000 --- gcc-3.3/gcc/ada/5qtaprop.adb 2002-03-14 10:58:37.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 29,36 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- 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). -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 185,192 **** -- In the current implementation, this is the task assigned permanently -- as the regular GNU/Linux kernel. ! All_Tasks_L : aliased RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). -- The followings are internal configuration constants needed. Next_Serial_Number : Task_Serial_Number := 100; --- 183,192 ---- -- 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; *************** package body System.Task_Primitives.Oper *** 722,733 **** -- 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)); --- 722,731 ---- -- 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)); *************** package body System.Task_Primitives.Oper *** 756,762 **** end if; end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Prio : constant System.Any_Priority := Current_Task.Common.LL.Active_Priority; --- 754,762 ---- 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; *************** package body System.Task_Primitives.Oper *** 872,878 **** end if; end Unlock; ! procedure Unlock (L : access RTS_Lock) is Flags : Integer; begin pragma Debug (Printk ("procedure Unlock (RTS_Lock) called" & LF)); --- 872,878 ---- 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)); *************** package body System.Task_Primitives.Oper *** 1607,1633 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! pragma Debug (Printk ("procedure Lock_All_Tasks_List called" & LF)); ! ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! pragma Debug (Printk ("procedure Unlock_All_Tasks_List called" & LF)); ! ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ----------------- -- Stack_Guard -- --- 1607,1629 ---- 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; ----------------- -- Stack_Guard -- *************** package body System.Task_Primitives.Oper *** 1770,1776 **** -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); Enter_Task (Environment_Task); end Initialize; --- 1766,1775 ---- -- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5qtaspri.ads gcc-3.3/gcc/ada/5qtaspri.ads *** gcc-3.2.3/gcc/ada/5qtaspri.ads 2001-10-04 17:50:42.000000000 +0000 --- gcc-3.3/gcc/ada/5qtaspri.ads 2002-03-14 10:58:37.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 1991-2001, Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5qvxwork.ads gcc-3.3/gcc/ada/5qvxwork.ads *** gcc-3.2.3/gcc/ada/5qvxwork.ads 2002-05-07 08:22:03.000000000 +0000 --- gcc-3.3/gcc/ada/5qvxwork.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,111 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . V X W O R K S -- - -- -- - -- S p e c -- - -- -- - -- $Revision: 1.1.16.2 $ - -- -- - -- Copyright (C) 1998 - 2001 Free Software Foundation -- - -- -- - -- GNARL is 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 PPC VxWorks 6.0 version of this package. A different version - -- is used for VxWorks 5.x - - with Interfaces.C; - - package System.VxWorks is - pragma Preelaborate (System.VxWorks); - - package IC renames Interfaces.C; - - -- Define enough of a Wind Task Control Block in order to - -- obtain the inherited priority. When porting this to - -- different versions of VxWorks (this is based on 6.0), - -- be sure to look at the definition for WIND_TCB located - -- in $WIND_BASE/target/h/taskLib.h - - type Wind_Fill_1 is array (0 .. 16#6B#) of IC.unsigned_char; - type Wind_Fill_2 is array (16#74# .. 16#10F#) of IC.unsigned_char; - - type Wind_TCB is record - Fill_1 : Wind_Fill_1; -- 0x00 - 0x6b - Priority : IC.int; -- 0x6c - 0x6f, current (inherited) priority - Normal_Priority : IC.int; -- 0x70 - 0x73, base priority - Fill_2 : Wind_Fill_2; -- 0x74 - 0x10f - spare1 : Address; -- 0x110 - 0x113 - spare2 : Address; -- 0x114 - 0x117 - spare3 : Address; -- 0x118 - 0x11b - spare4 : Address; -- 0x11c - 0x11f - end record; - type Wind_TCB_Ptr is access Wind_TCB; - - -- Floating point context record. PPC version - - FP_NUM_DREGS : constant := 32; - type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double; - - type FP_CONTEXT is record - fpr : Fpr_Array; - fpcsr : IC.int; - pad : IC.int; - end record; - pragma Convention (C, FP_CONTEXT); - - Num_HW_Interrupts : constant := 256; - - -- For VxWorks 6.0 - type TASK_DESC is record - td_id : IC.int; -- task id - td_priority : IC.int; -- task priority - td_status : IC.int; -- task status - td_options : IC.int; -- task option bits (see below) - td_entry : Address; -- original entry point of task - td_sp : Address; -- saved stack pointer - td_pStackBase : Address; -- the bottom of the stack - td_pStackLimit : Address; -- the effective end of the stack - td_pStackEnd : Address; -- the actual end of the stack - td_stackSize : IC.int; -- size of stack in bytes - td_stackCurrent : IC.int; -- current stack usage in bytes - td_stackHigh : IC.int; -- maximum stack usage in bytes - td_stackMargin : IC.int; -- current stack margin in bytes - - td_PExcStkBase : Address; -- exception stack base - td_PExcStkPtr : Address; -- exception stack pointer - td_ExcStkHigh : IC.int; -- exception stack max usage - td_ExcStkMgn : IC.int; -- exception stack margin - - td_errorStatus : IC.int; -- most recent task error status - td_delay : IC.int; -- delay/timeout ticks - - td_PdId : Address; -- task's home protection domain - td_name : Address; -- name of task - end record; - - pragma Convention (C, TASK_DESC); - - end System.VxWorks; --- 0 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5rosinte.adb gcc-3.3/gcc/ada/5rosinte.adb *** gcc-3.2.3/gcc/ada/5rosinte.adb 2001-10-02 13:42:27.000000000 +0000 --- gcc-3.3/gcc/ada/5rosinte.adb 2002-03-14 10:58:37.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2000 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5rosinte.ads gcc-3.3/gcc/ada/5rosinte.ads *** gcc-3.2.3/gcc/ada/5rosinte.ads 2003-01-29 17:34:08.000000000 +0000 --- gcc-3.3/gcc/ada/5rosinte.ads 2003-01-29 17:40:47.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1.4.1 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5rparame.adb gcc-3.3/gcc/ada/5rparame.adb *** gcc-3.2.3/gcc/ada/5rparame.adb 2002-05-07 08:22:03.000000000 +0000 --- gcc-3.3/gcc/ada/5rparame.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1997-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5rtpopsp.adb gcc-3.3/gcc/ada/5rtpopsp.adb *** gcc-3.2.3/gcc/ada/5rtpopsp.adb 2003-01-29 17:34:08.000000000 +0000 --- gcc-3.3/gcc/ada/5rtpopsp.adb 2003-01-29 17:40:47.000000000 +0000 *************** *** 7,13 **** -- -- -- B o d y -- -- -- ! -- $Revision: 1.1.2.1 $ -- -- -- Copyright (C) 1991-1999, Florida State University -- -- -- --- 7,13 ---- -- -- -- B o d y -- -- -- ! -- $Revision: 1.1.4.1 $ -- -- -- Copyright (C) 1991-1999, Florida State University -- -- -- diff -Nrc3pad gcc-3.2.3/gcc/ada/5sintman.adb gcc-3.3/gcc/ada/5sintman.adb *** gcc-3.2.3/gcc/ada/5sintman.adb 2002-05-07 08:22:03.000000000 +0000 --- gcc-3.3/gcc/ada/5sintman.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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- -- *************** begin *** 172,184 **** act.sa_mask := mask; Keep_Unmasked (Abort_Task_Interrupt) := True; - Keep_Unmasked (SIGXCPU) := True; - Keep_Unmasked (SIGFPE) := True; - Result := - sigaction - (Signal (SIGFPE), act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the -- same time, disable the ability of handling this signal --- 171,176 ---- *************** begin *** 190,206 **** Keep_Unmasked (SIGINT) := True; end if; ! for J in ! Exception_Interrupts'First + 1 .. Exception_Interrupts'Last loop Keep_Unmasked (Exception_Interrupts (J)) := True; ! ! if Unreserve_All_Interrupts = 0 then ! Result := ! sigaction ! (Signal (Exception_Interrupts (J)), act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; end loop; for J in Unmasked'Range loop --- 182,194 ---- 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 diff -Nrc3pad gcc-3.2.3/gcc/ada/5smastop.adb gcc-3.3/gcc/ada/5smastop.adb *** gcc-3.2.3/gcc/ada/5smastop.adb 2001-10-02 13:42:27.000000000 +0000 --- gcc-3.3/gcc/ada/5smastop.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,159 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- SYSTEM.MACHINE_STATE_OPERATIONS -- - -- -- - -- B o d y -- - -- (Version using the GCC stack unwinding mechanism) -- - -- -- - -- $Revision: 1.1 $ - -- -- - -- 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- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- - -- -- - ------------------------------------------------------------------------------ - - -- This version of System.Machine_State_Operations is for use on - -- systems where the GCC stack unwinding mechanism is supported. - -- It is currently only used on Solaris - - package body System.Machine_State_Operations is - - use System.Storage_Elements; - use System.Exceptions; - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - function Machine_State_Length return Storage_Offset; - pragma Import (C, Machine_State_Length, "__gnat_machine_state_length"); - - function Gnat_Malloc (Size : Storage_Offset) return Machine_State; - pragma Import (C, Gnat_Malloc, "__gnat_malloc"); - - begin - return Gnat_Malloc (Machine_State_Length); - end Allocate_Machine_State; - - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - procedure c_enter_handler (m : Machine_State; handler : Handler_Loc); - pragma Import (C, c_enter_handler, "__gnat_enter_handler"); - - begin - c_enter_handler (M, Handler); - end Enter_Handler; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - return Loc; - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - procedure Gnat_Free (M : in Machine_State); - pragma Import (C, Gnat_Free, "__gnat_free"); - - begin - Gnat_Free (M); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - function c_get_code_loc (m : Machine_State) return Code_Loc; - pragma Import (C, c_get_code_loc, "__gnat_get_code_loc"); - - begin - return c_get_code_loc (M); - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length return Storage_Offset is - - function c_machine_state_length return Storage_Offset; - pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); - - begin - return c_machine_state_length; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - procedure c_pop_frame (m : Machine_State); - pragma Import (C, c_pop_frame, "__gnat_pop_frame"); - - begin - c_pop_frame (M); - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - procedure c_set_machine_state (m : Machine_State); - pragma Import (C, c_set_machine_state, "__gnat_set_machine_state"); - - begin - c_set_machine_state (M); - Pop_Frame (M, System.Null_Address); - end Set_Machine_State; - - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) is - begin - null; - end Set_Signal_Machine_State; - - end System.Machine_State_Operations; --- 0 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5sosinte.adb gcc-3.3/gcc/ada/5sosinte.adb *** gcc-3.2.3/gcc/ada/5sosinte.adb 2001-10-02 13:42:27.000000000 +0000 --- gcc-3.3/gcc/ada/5sosinte.adb 2002-03-14 10:58:37.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5sosinte.ads gcc-3.3/gcc/ada/5sosinte.ads *** gcc-3.2.3/gcc/ada/5sosinte.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5sosinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5sparame.adb gcc-3.3/gcc/ada/5sparame.adb *** gcc-3.2.3/gcc/ada/5sparame.adb 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5sparame.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5ssystem.ads gcc-3.3/gcc/ada/5ssystem.ads *** gcc-3.2.3/gcc/ada/5ssystem.ads 2002-05-04 03:27:15.000000000 +0000 --- gcc-3.3/gcc/ada/5ssystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (SUN Solaris Version) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 92,118 **** -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 91,104 ---- -- 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 *************** private *** 130,137 **** --- 116,126 ---- -- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5staprop.adb gcc-3.3/gcc/ada/5staprop.adb *** gcc-3.2.3/gcc/ada/5staprop.adb 2001-12-16 01:13:28.000000000 +0000 --- gcc-3.3/gcc/ada/5staprop.adb 2002-10-23 08:27:55.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 108,118 **** -- Local Data -- ------------------ - 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. - -- The following are logically constants, but need to be initialized -- at run time. --- 106,111 ---- *************** package body System.Task_Primitives.Oper *** 128,135 **** -- Key used to find the Ada Task_ID associated with a thread, -- at least for C threads unknown to the Ada run-time system. ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Next_Serial_Number : Task_Serial_Number := 100; -- We start at 100, to reserve some special values for --- 121,130 ---- -- Key used to find the Ada Task_ID associated with a thread, -- at least for C threads unknown to the Ada run-time system. ! 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 Next_Serial_Number : Task_Serial_Number := 100; -- We start at 100, to reserve some special values for *************** package body System.Task_Primitives.Oper *** 140,148 **** -- Priority Support -- ------------------------ - Dynamic_Priority_Support : constant Boolean := True; - -- controls whether we poll for pending priority changes during sleeps - Priority_Ceiling_Emulation : constant Boolean := True; -- controls whether we emulate priority ceiling locking --- 135,140 ---- *************** package body System.Task_Primitives.Oper *** 194,200 **** 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. --- 186,192 ---- 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. *************** package body System.Task_Primitives.Oper *** 245,257 **** function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - type Ptr is access Task_ID; - function To_Ptr is new Unchecked_Conversion (Interfaces.C.unsigned, Ptr); - function To_Ptr is new Unchecked_Conversion (System.Address, Ptr); - - type Iptr is access Interfaces.C.unsigned; - function To_Iptr is new Unchecked_Conversion (Interfaces.C.unsigned, Iptr); - function Thread_Body_Access is new Unchecked_Conversion (System.Address, Thread_Body); --- 237,242 ---- *************** package body System.Task_Primitives.Oper *** 259,264 **** --- 244,252 ---- -- 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 -- *************** package body System.Task_Primitives.Oper *** 309,318 **** -- 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 "Write_Lock (All_Tasks_L'Access);" because ! -- we don't yet have an ATCB, and so can't pass the safety check. ! Result := mutex_lock (All_Tasks_L.L'Access); Q := null; P := Fake_ATCB_List; --- 297,306 ---- -- 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; *************** package body System.Task_Primitives.Oper *** 415,424 **** end if; end loop; ! Result := mutex_unlock (All_Tasks_L.L'Access); ! -- We cannot use "Unlock (All_Tasks_L'Access);" because ! -- we did not use Write_Lock, and so would not pass the checks. return Self_ID; end New_Fake_ATCB; --- 403,412 ---- 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; *************** package body System.Task_Primitives.Oper *** 550,556 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as All_Tasks_L, 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. --- 538,544 ---- -- 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. *************** package body System.Task_Primitives.Oper *** 658,681 **** pragma Assert (Record_Lock (Lock_Ptr (L))); end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); ! Result := mutex_lock (L.L'Access); ! pragma Assert (Result = 0); ! pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; - begin ! pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); ! Result := mutex_lock (T.Common.LL.L.L'Access); ! pragma Assert (Result = 0); ! pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); end Write_Lock; --------------- --- 646,673 ---- pragma Assert (Record_Lock (Lock_Ptr (L))); 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)))); ! Result := mutex_lock (L.L'Access); ! pragma Assert (Result = 0); ! pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); ! end if; end Write_Lock; 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))); ! Result := mutex_lock (T.Common.LL.L.L'Access); ! pragma Assert (Result = 0); ! pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); ! end if; end Write_Lock; --------------- *************** package body System.Task_Primitives.Oper *** 693,699 **** procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin pragma Assert (Check_Unlock (Lock_Ptr (L))); --- 685,690 ---- *************** package body System.Task_Primitives.Oper *** 715,736 **** end if; end Unlock; ! procedure Unlock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); ! Result := mutex_unlock (L.L'Access); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin ! pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access))); ! Result := mutex_unlock (T.Common.LL.L.L'Access); ! pragma Assert (Result = 0); end Unlock; -- For the time delay implementation, we need to make sure we --- 706,729 ---- 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 ! pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); ! Result := mutex_unlock (L.L'Access); ! pragma Assert (Result = 0); ! end if; end Unlock; 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))); ! Result := mutex_unlock (T.Common.LL.L.L'Access); ! pragma Assert (Result = 0); ! end if; end Unlock; -- For the time delay implementation, we need to make sure we *************** package body System.Task_Primitives.Oper *** 899,914 **** -- 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. ! Lock_All_Tasks_List; ! for I in Known_Tasks'Range loop ! if Known_Tasks (I) = null then ! Known_Tasks (I) := Self_ID; ! Self_ID.Known_Tasks_Index := I; exit; end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 892,908 ---- -- 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. ! 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; -------------- *************** package body System.Task_Primitives.Oper *** 920,932 **** return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; ! ---------------------- ! -- Initialize_TCB -- ! ---------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is ! Result : Interfaces.C.int; ! begin -- Give the task a unique serial number. --- 914,925 ---- return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; ! -------------------- ! -- 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 *** 935,959 **** pragma Assert (Next_Serial_Number /= 0); Self_ID.Common.LL.Thread := To_thread_t (-1); ! Result := mutex_init ! (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); ! Self_ID.Common.LL.L.Level := ! Private_Task_Serial_Number (Self_ID.Serial_Number); ! pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then Result := mutex_destroy (Self_ID.Common.LL.L.L'Access); pragma Assert (Result = 0); - Succeeded := False; - else - Succeeded := True; end if; - else Succeeded := False; end if; end Initialize_TCB; --- 928,955 ---- pragma Assert (Next_Serial_Number /= 0); Self_ID.Common.LL.Thread := To_thread_t (-1); ! ! if not Single_Lock then ! Result := mutex_init ! (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); ! Self_ID.Common.LL.L.Level := ! Private_Task_Serial_Number (Self_ID.Serial_Number); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! end if; if Result = 0 then Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0); pragma Assert (Result = 0 or else Result = ENOMEM); + end if; ! if Result = 0 then ! Succeeded := True; ! else ! if not Single_Lock then Result := mutex_destroy (Self_ID.Common.LL.L.L'Access); pragma Assert (Result = 0); end if; Succeeded := False; end if; end Initialize_TCB; *************** package body System.Task_Primitives.Oper *** 1042,1049 **** begin T.Common.LL.Thread := To_thread_t (0); ! Result := mutex_destroy (T.Common.LL.L.L'Access); ! pragma Assert (Result = 0); Result := cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); --- 1038,1049 ---- begin T.Common.LL.Thread := To_thread_t (0); ! ! if not Single_Lock then ! Result := mutex_destroy (T.Common.LL.L.L'Access); ! pragma Assert (Result = 0); ! end if; ! Result := cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 1083,1098 **** pragma Assert (Result = 0); end Abort_Task; ! ------------- ! -- Sleep -- ! ------------- procedure Sleep (Self_ID : Task_ID; Reason : Task_States) is Result : Interfaces.C.int; - begin pragma Assert (Check_Sleep (Reason)); --- 1083,1097 ---- pragma Assert (Result = 0); end Abort_Task; ! ----------- ! -- Sleep -- ! ----------- procedure Sleep (Self_ID : Task_ID; Reason : Task_States) is Result : Interfaces.C.int; begin pragma Assert (Check_Sleep (Reason)); *************** package body System.Task_Primitives.Oper *** 1104,1114 **** Set_Priority (Self_ID, Self_ID.Common.Base_Priority); end if; ! Result := cond_wait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); ! pragma Assert (Result = 0 or else Result = EINTR); pragma Assert (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); end Sleep; -- Note that we are relying heaviliy here on the GNAT feature --- 1103,1119 ---- Set_Priority (Self_ID, Self_ID.Common.Base_Priority); end if; ! if Single_Lock then ! Result := cond_wait ! (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access); ! else ! Result := cond_wait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); ! end if; ! pragma Assert (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); + pragma Assert (Result = 0 or else Result = EINTR); end Sleep; -- Note that we are relying heaviliy here on the GNAT feature *************** package body System.Task_Primitives.Oper *** 1121,1127 **** -- ??? -- We are taking liberties here with the semantics of the delays. -- That is, we make no distinction between delays on the Calendar clock ! -- and delays on the Real_Time clock. That is technically incorrect, if -- the Calendar clock happens to be reset or adjusted. -- To solve this defect will require modification to the compiler -- interface, so that it can pass through more information, to tell --- 1126,1132 ---- -- ??? -- We are taking liberties here with the semantics of the delays. -- That is, we make no distinction between delays on the Calendar clock ! -- and delays on the Real_Time clock. That is technically incorrect, if -- the Calendar clock happens to be reset or adjusted. -- To solve this defect will require modification to the compiler -- interface, so that it can pass through more information, to tell *************** package body System.Task_Primitives.Oper *** 1157,1165 **** -- Annex D requires that completion of a delay cause the task -- to go to the end of its priority queue, regardless of whether ! -- the task actually was suspended by the delay. Since -- cond_timedwait does not do this on Solaris, we add a call ! -- to thr_yield at the end. We might do this at the beginning, -- instead, but then the round-robin effect would not be the -- same; the delayed task would be ahead of other tasks of the -- same priority that awoke while it was sleeping. --- 1162,1170 ---- -- Annex D requires that completion of a delay cause the task -- to go to the end of its priority queue, regardless of whether ! -- the task actually was suspended by the delay. Since -- cond_timedwait does not do this on Solaris, we add a call ! -- to thr_yield at the end. We might do this at the beginning, -- instead, but then the round-robin effect would not be the -- same; the delayed task would be ahead of other tasks of the -- same priority that awoke while it was sleeping. *************** package body System.Task_Primitives.Oper *** 1177,1205 **** -- For Timed_Delay, we are not expecting any cond_signals or -- other interruptions, except for priority changes and aborts. -- Therefore, we don't want to return unless the delay has ! -- actually expired, or the call has been aborted. In this -- case, since we want to implement the entire delay statement -- semantics, we do need to check for pending abort and priority ! -- changes. We can quietly handle priority changes inside the -- procedure, since there is no entry-queue reordering involved. ----------------- -- 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. - - -- Yielded should be False unles we know for certain that the - -- operation resulted in the calling task going to the end of - -- the dispatching queue for its priority. - - -- ??? - -- This version presumes the worst, so Yielded is always False. - -- On some targets, if cond_timedwait always yields, we could - -- set Yielded to True just before the cond_timedwait call. - procedure Timed_Sleep (Self_ID : Task_ID; Time : Duration; --- 1182,1197 ---- -- For Timed_Delay, we are not expecting any cond_signals or -- other interruptions, except for priority changes and aborts. -- Therefore, we don't want to return unless the delay has ! -- actually expired, or the call has been aborted. In this -- case, since we want to implement the entire delay statement -- semantics, we do need to check for pending abort and priority ! -- changes. We can quietly handle priority changes inside the -- procedure, since there is no entry-queue reordering involved. ----------------- -- Timed_Sleep -- ----------------- procedure Timed_Sleep (Self_ID : Task_ID; Time : Duration; *************** package body System.Task_Primitives.Oper *** 1232,1239 **** or else (Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change); ! Result := cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 1224,1238 ---- or else (Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change); ! if Single_Lock then ! Result := cond_timedwait (Self_ID.Common.LL.CV'Access, ! Single_RTS_Lock.L'Access, Request'Access); ! else ! Result := cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L.L'Access, Request'Access); ! end if; ! ! Yielded := True; exit when Abs_Time <= Monotonic_Clock; *************** package body System.Task_Primitives.Oper *** 1255,1264 **** -- 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; --- 1254,1259 ---- *************** package body System.Task_Primitives.Oper *** 1268,1273 **** --- 1263,1269 ---- Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; + Yielded : Boolean := False; begin -- Only the little window between deferring abort and *************** package body System.Task_Primitives.Oper *** 1275,1280 **** --- 1271,1281 ---- -- check for pending abort and priority change below! SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); if Mode = Relative then *************** package body System.Task_Primitives.Oper *** 1299,1306 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Result := cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 1300,1314 ---- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! if Single_Lock then ! Result := cond_timedwait (Self_ID.Common.LL.CV'Access, ! Single_RTS_Lock.L'Access, Request'Access); ! else ! Result := cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L.L'Access, Request'Access); ! end if; ! ! Yielded := True; exit when Abs_Time <= Monotonic_Clock; *************** package body System.Task_Primitives.Oper *** 1316,1322 **** end if; Unlock (Self_ID); ! thr_yield; SSL.Abort_Undefer.all; end Timed_Delay; --- 1324,1338 ---- end if; Unlock (Self_ID); ! ! if Single_Lock then ! Unlock_RTS; ! end if; ! ! if not Yielded then ! thr_yield; ! end if; ! SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 1329,1335 **** Reason : Task_States) is Result : Interfaces.C.int; - begin pragma Assert (Check_Wakeup (T, Reason)); Result := cond_signal (T.Common.LL.CV'Access); --- 1345,1350 ---- *************** package body System.Task_Primitives.Oper *** 1400,1405 **** --- 1415,1424 ---- return False; end if; + if Single_Lock then + return True; + end if; + -- Check that TCB lock order rules are satisfied P := Self_ID.Common.LL.Locks; *************** package body System.Task_Primitives.Oper *** 1435,1440 **** --- 1454,1463 ---- L.Owner := To_Owner_ID (Self_ID); + if Single_Lock then + return True; + end if; + -- Check that TCB lock order rules are satisfied P := Self_ID.Common.LL.Locks; *************** package body System.Task_Primitives.Oper *** 1463,1468 **** --- 1486,1495 ---- return False; end if; + if Single_Lock then + return True; + end if; + -- Check that caller is holding own lock, on top of list if Self_ID.Common.LL.Locks /= *************** package body System.Task_Primitives.Oper *** 1501,1506 **** --- 1528,1537 ---- L.Owner := To_Owner_ID (Self_ID); + if Single_Lock then + return True; + end if; + -- Check that TCB lock order rules are satisfied P := Self_ID.Common.LL.Locks; *************** package body System.Task_Primitives.Oper *** 1566,1572 **** if Unlock_Count - Check_Count > 1000 then Check_Count := Unlock_Count; ! Old_Owner := To_Task_ID (All_Tasks_L.Owner); end if; -- Check that caller is abort-deferred --- 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 *************** package body System.Task_Primitives.Oper *** 1596,1602 **** function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is Self_ID : Task_ID := Self; - begin -- Check that caller is abort-deferred --- 1627,1632 ---- *************** package body System.Task_Primitives.Oper *** 1664,1686 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 1694,1716 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 1717,1726 **** ---------------- 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 --- 1747,1756 ---- ---------------- 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 *************** package body System.Task_Primitives.Oper *** 1740,1810 **** -- _SC_NPROCESSORS_CONF, minus one. procedure Configure_Processors is - Proc_Acc : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR"); begin if Proc_Acc.all'Length /= 0 then - -- Environment variable is defined ! declare ! Proc : aliased processorid_t; -- User processor # ! Last_Proc : processorid_t; -- Last processor # ! ! begin ! Last_Proc := Num_Procs - 1; ! ! if Last_Proc = -1 then ! -- Unable to read system variable _SC_NPROCESSORS_CONF ! -- Ignore environment variable GNAT_PROCESSOR null; ! else ! Proc := processorid_t'Value (Proc_Acc.all); ! ! if Proc < -2 or Proc > Last_Proc then ! raise Constraint_Error; ! ! elsif Proc = -2 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; ! ! exception ! when Constraint_Error => ! ! -- Illegal environment variable GNAT_PROCESSOR - ignored ! ! null; ! end; end if; end Configure_Processors; -- Start of processing for Initialize --- 1770,1820 ---- -- _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 *************** package body System.Task_Primitives.Oper *** 1821,1827 **** -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); Enter_Task (Environment_Task); --- 1831,1837 ---- -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); Enter_Task (Environment_Task); *************** package body System.Task_Primitives.Oper *** 1861,1867 **** 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 --- 1871,1876 ---- *************** begin *** 1892,1903 **** if Dispatching_Policy = 'F' then declare ! Result : Interfaces.C.long; Class_Info : aliased struct_pcinfo; Secs, Nsecs : Interfaces.C.long; begin - -- If a pragma Time_Slice is specified, takes the value in account. if Time_Slice_Val > 0 then --- 1901,1911 ---- if Dispatching_Policy = 'F' then declare ! Result : Interfaces.C.long; Class_Info : aliased struct_pcinfo; Secs, Nsecs : Interfaces.C.long; begin -- If a pragma Time_Slice is specified, takes the value in account. if Time_Slice_Val > 0 then *************** begin *** 1918,1924 **** Class_Info.pc_clname (1) := 'R'; Class_Info.pc_clname (2) := 'T'; ! Class_Info.pc_clname (3) := ASCII.Nul; Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID, Class_Info'Address); --- 1926,1932 ---- Class_Info.pc_clname (1) := 'R'; Class_Info.pc_clname (2) := 'T'; ! Class_Info.pc_clname (3) := ASCII.NUL; Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID, Class_Info'Address); diff -Nrc3pad gcc-3.2.3/gcc/ada/5stasinf.adb gcc-3.3/gcc/ada/5stasinf.adb *** gcc-3.2.3/gcc/ada/5stasinf.adb 2002-05-07 08:22:03.000000000 +0000 --- gcc-3.3/gcc/ada/5stasinf.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5stasinf.ads gcc-3.3/gcc/ada/5stasinf.ads *** gcc-3.2.3/gcc/ada/5stasinf.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5stasinf.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5staspri.ads gcc-3.3/gcc/ada/5staspri.ads *** gcc-3.2.3/gcc/ada/5staspri.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5staspri.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5stpopse.adb gcc-3.3/gcc/ada/5stpopse.adb *** gcc-3.2.3/gcc/ada/5stpopse.adb 2002-05-07 08:22:03.000000000 +0000 --- gcc-3.3/gcc/ada/5stpopse.adb 2002-10-23 08:27:55.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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- -- --- 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** separate (System.Task_Primitives.Operati *** 139,144 **** --- 137,153 ---- -- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5svxwork.ads gcc-3.3/gcc/ada/5svxwork.ads *** gcc-3.2.3/gcc/ada/5svxwork.ads 2002-05-07 08:22:03.000000000 +0000 --- gcc-3.3/gcc/ada/5svxwork.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- Copyright (C) 1998-2001 Free Software Foundation -- -- -- -- GNARL is 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) 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- -- *************** *** 33,69 **** -- -- ------------------------------------------------------------------------------ ! -- This is the SPARC64 VxWorks version of this package. ! with Interfaces.C; package System.VxWorks is pragma Preelaborate (System.VxWorks); ! package IC renames Interfaces.C; ! ! -- Define enough of a Wind Task Control Block in order to ! -- obtain the inherited priority. When porting this to ! -- different versions of VxWorks (this is based on 5.3[.1]), ! -- be sure to look at the definition for WIND_TCB located ! -- in $WIND_BASE/target/h/taskLib.h ! ! type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char; ! type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char; ! ! type Wind_TCB is record ! Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f ! Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority ! Normal_Priority : IC.int; -- 0x44 - 0x47, base priority ! Fill_2 : Wind_Fill_2; -- 0x48 - 0x107 ! spare1 : Address; -- 0x108 - 0x10b ! spare2 : Address; -- 0x10c - 0x10f ! spare3 : Address; -- 0x110 - 0x113 ! spare4 : Address; -- 0x114 - 0x117 ! end record; ! type Wind_TCB_Ptr is access Wind_TCB; ! ! -- Floating point context record. SPARCV9 version FP_NUM_DREGS : constant := 32; --- 32,45 ---- -- -- ------------------------------------------------------------------------------ ! -- This is the Sparc64 VxWorks version of this package. ! with Interfaces; package System.VxWorks is pragma Preelaborate (System.VxWorks); ! -- Floating point context record. SPARCV9 version FP_NUM_DREGS : constant := 32; *************** package System.VxWorks is *** 74,110 **** for Fpd_Array'Alignment use 8; type FP_CONTEXT is record ! fpd : Fpd_Array; ! fsr : RType; end record; for FP_CONTEXT'Alignment use 8; pragma Convention (C, FP_CONTEXT); ! -- Number of entries in hardware interrupt vector table. Value of ! -- 0 disables hardware interrupt handling until we have time to test it ! -- on this target. ! Num_HW_Interrupts : constant := 0; ! ! -- VxWorks 5.3 and 5.4 version ! type TASK_DESC is record ! td_id : IC.int; -- task id ! td_name : Address; -- name of task ! td_priority : IC.int; -- task priority ! td_status : IC.int; -- task status ! td_options : IC.int; -- task option bits (see below) ! td_entry : Address; -- original entry point of task ! td_sp : Address; -- saved stack pointer ! td_pStackBase : Address; -- the bottom of the stack ! td_pStackLimit : Address; -- the effective end of the stack ! td_pStackEnd : Address; -- the actual end of the stack ! td_stackSize : IC.int; -- size of stack in bytes ! td_stackCurrent : IC.int; -- current stack usage in bytes ! td_stackHigh : IC.int; -- maximum stack usage in bytes ! td_stackMargin : IC.int; -- current stack margin in bytes ! td_errorStatus : IC.int; -- most recent task error status ! td_delay : IC.int; -- delay/timeout ticks ! end record; ! pragma Convention (C, TASK_DESC); end System.VxWorks; --- 50,63 ---- for Fpd_Array'Alignment use 8; type FP_CONTEXT is record ! fpd : Fpd_Array; ! fsr : RType; end record; for FP_CONTEXT'Alignment use 8; 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.2.3/gcc/ada/5tosinte.ads gcc-3.3/gcc/ada/5tosinte.ads *** gcc-3.2.3/gcc/ada/5tosinte.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5tosinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** package System.OS_Interface is *** 119,124 **** --- 118,125 ---- SIGFREEZE : constant := 34; -- used by CPR (Solaris) SIGTHAW : constant := 35; -- used by CPR (Solaris) SIGCANCEL : constant := 36; -- used for thread cancel (Solaris) + SIGRTMIN : constant := 38; -- first (highest-priority) realtime signal + SIGRTMAX : constant := 45; -- last (lowest-priority) realtime signal type Signal_Set is array (Natural range <>) of Signal; *************** package System.OS_Interface is *** 126,132 **** (SIGTRAP, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); Reserved : constant Signal_Set := ! (SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGWAITING); type sigset_t is private; --- 127,133 ---- (SIGTRAP, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); Reserved : constant Signal_Set := ! (SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGWAITING, SIGRTMAX); type sigset_t is private; diff -Nrc3pad gcc-3.2.3/gcc/ada/5uintman.adb gcc-3.3/gcc/ada/5uintman.adb *** gcc-3.2.3/gcc/ada/5uintman.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/5uintman.adb 2002-03-14 10:58:38.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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-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- -- *************** begin *** 208,235 **** for J in Exception_Interrupts'Range loop Keep_Unmasked (Exception_Interrupts (J)) := True; ! if Unreserve_All_Interrupts = 0 then ! Result := ! sigaction ! (Signal (Exception_Interrupts (J)), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; end loop; Keep_Unmasked (Abort_Task_Interrupt) := True; - Keep_Unmasked (SIGBUS) := True; - Keep_Unmasked (SIGFPE) := True; - Result := - sigaction - (Signal (SIGFPE), act'Unchecked_Access, - old_act'Unchecked_Access); - Keep_Unmasked (SIGALRM) := True; Keep_Unmasked (SIGSTOP) := True; Keep_Unmasked (SIGKILL) := True; - Keep_Unmasked (SIGXCPU) := 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 --- 207,224 ---- 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 diff -Nrc3pad gcc-3.2.3/gcc/ada/5uosinte.ads gcc-3.3/gcc/ada/5uosinte.ads *** gcc-3.2.3/gcc/ada/5uosinte.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5uosinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vasthan.adb gcc-3.3/gcc/ada/5vasthan.adb *** gcc-3.2.3/gcc/ada/5vasthan.adb 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vasthan.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** with Ada.Task_Identification; *** 60,66 **** with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; - with Ada.Unchecked_Deallocation; package body System.AST_Handling is --- 59,64 ---- *************** package body System.AST_Handling is *** 162,173 **** function To_AST_Handler is new Ada.Unchecked_Conversion (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); - function To_AST_Data_Handler_Ref is new Ada.Unchecked_Conversion - (System.Aux_DEC.AST_Handler, AST_Handler_Data_Ref); - - function To_AST_Data_Handler_Ref is new Ada.Unchecked_Conversion - (AST_Handler, AST_Handler_Data_Ref); - -- Each time Create_AST_Handler is called, a new value of this record -- type is created, containing a copy of the procedure descriptor for -- the routine used to handle all AST's (Process_AST), and the Task_Id --- 160,165 ---- *************** package body System.AST_Handling is *** 198,206 **** type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; type AST_Handler_Vector_Ref is access all AST_Handler_Vector; - procedure Free is new Ada.Unchecked_Deallocation - (Object => AST_Handler_Vector, - Name => AST_Handler_Vector_Ref); -- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record -- removed due to problem with controlled attribute, consequence is that --- 190,195 ---- *************** package body System.AST_Handling is *** 211,219 **** Vector : AST_Handler_Vector_Ref; end record; - procedure Finalize (Object : in out AST_Vector_Ptr); - -- Used to get rid of allocated AST_Vector's - AST_Vector_Init : AST_Vector_Ptr; -- Initial value, treated as constant, Vector will be null. --- 200,205 ---- *************** package body System.AST_Handling is *** 308,316 **** type AST_Server_Task_Ptr is access all AST_Server_Task; -- Type used to allocate server tasks - function To_Integer is new Ada.Unchecked_Conversion - (ATID.Task_Id, Integer); - ----------------------- -- Local Subprograms -- ----------------------- --- 294,299 ---- *************** package body System.AST_Handling is *** 532,546 **** Total_Number := AST_Service_Queue_Size; end Expand_AST_Packet_Pool; - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out AST_Vector_Ptr) is - begin - Free (Object.Vector); - end Finalize; - ----------------- -- Process_AST -- ----------------- --- 515,520 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vinmaop.adb gcc-3.3/gcc/ada/5vinmaop.adb *** gcc-3.2.3/gcc/ada/5vinmaop.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/5vinmaop.adb 2002-03-14 10:58:40.000000000 +0000 *************** *** 7,15 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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- -- --- 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- -- *************** package body System.Interrupt_Management *** 57,63 **** use type unsigned_short; function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); package POP renames System.Task_Primitives.Operations; ---------------------------- --- 56,61 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vinterr.adb gcc-3.3/gcc/ada/5vinterr.adb *** gcc-3.2.3/gcc/ada/5vinterr.adb 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vinterr.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- 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,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- -- *************** with System.Interrupt_Management.Operati *** 83,95 **** -- Set_Interrupt_Mask -- IS_Member -- Environment_Mask - -- All_Tasks_Mask pragma Elaborate_All (System.Interrupt_Management.Operations); - with System.Error_Reporting; - pragma Warnings (Off, System.Error_Reporting); - -- used for Shutdown - with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock --- 82,89 ---- *************** with System.Tasking.Initialization; *** 124,135 **** -- used for Defer_Abort -- Undefer_Abort with Unchecked_Conversion; package body System.Interrupts is use Tasking; ! use System.Error_Reporting; use Ada.Exceptions; package PRI renames System.Task_Primitives; --- 118,132 ---- -- used for Defer_Abort -- Undefer_Abort + with System.Parameters; + -- used for Single_Lock + with Unchecked_Conversion; package body System.Interrupts is use Tasking; ! use System.Parameters; use Ada.Exceptions; package PRI renames System.Task_Primitives; *************** package body System.Interrupts is *** 145,155 **** -- Local Tasks -- ----------------- ! -- WARNING: System.Tasking.Utilities performs calls to this task -- with low-level constructs. Do not change this spec without synchro- -- nizing it. task Interrupt_Manager is entry Initialize (Mask : IMNG.Interrupt_Mask); entry Attach_Handler --- 142,154 ---- -- Local Tasks -- ----------------- ! -- WARNING: System.Tasking.Stages performs calls to this task -- with low-level constructs. Do not change this spec without synchro- -- nizing it. task Interrupt_Manager is + entry Detach_Interrupt_Entries (T : Task_ID); + entry Initialize (Mask : IMNG.Interrupt_Mask); entry Attach_Handler *************** package body System.Interrupts is *** 173,180 **** E : Task_Entry_Index; Interrupt : Interrupt_ID); - entry Detach_Interrupt_Entries (T : Task_ID); - entry Block_Interrupt (Interrupt : Interrupt_ID); entry Unblock_Interrupt (Interrupt : Interrupt_ID); --- 172,177 ---- *************** package body System.Interrupts is *** 259,367 **** Access_Hold : Server_Task_Access; -- variable used to allocate Server_Task using "new". - L : aliased PRI.RTS_Lock; - -- L protects contents in tables above corresponding to interrupts - -- for which Server_ID (T) = null. - -- - -- If Server_ID (T) /= null then protection is via - -- per-task (TCB) lock of Server_ID (T). - -- - -- For deadlock prevention, L should not be locked after - -- any other lock is held. - - Task_Lock : array (Interrupt_ID'Range) of Boolean := (others => False); - -- Boolean flags to give matching Locking and Unlocking. See the comments - -- in Lock_Interrupt. - ----------------------- -- Local Subprograms -- ----------------------- - procedure Lock_Interrupt - (Self_ID : Task_ID; - Interrupt : Interrupt_ID); - -- protect the tables using L or per-task lock. Set the Boolean - -- value Task_Lock if the lock is made using per-task lock. - -- This information is needed so that Unlock_Interrupt - -- performs unlocking on the same lock. The situation we are preventing - -- is, for example, when Attach_Handler is called for the first time - -- we lock L and create an Server_Task. For a matching unlocking, if we - -- rely on the fact that there is a Server_Task, we will unlock the - -- per-task lock. - - procedure Unlock_Interrupt - (Self_ID : Task_ID; - Interrupt : Interrupt_ID); - function Is_Registered (Handler : Parameterless_Handler) return Boolean; ! -------------------- ! -- Lock_Interrupt -- ! -------------------- ! ! -- ????? ! -- This package has been modified several times. ! -- Do we still need this fancy locking scheme, now that more operations ! -- are entries of the interrupt manager task? ! -- ????? ! -- More likely, we will need to convert one or more entry calls to ! -- protected operations, because presently we are violating locking order ! -- rules by calling a task entry from within the runtime system. ! ! procedure Lock_Interrupt ! (Self_ID : Task_ID; ! Interrupt : Interrupt_ID) ! is ! begin ! Initialization.Defer_Abort (Self_ID); ! ! POP.Write_Lock (L'Access); ! ! if Task_Lock (Interrupt) then ! ! -- We need to use per-task lock. ! ! POP.Unlock (L'Access); ! POP.Write_Lock (Server_ID (Interrupt)); ! ! -- Rely on the fact that once Server_ID is set to a non-null ! -- value it will never be set back to null. ! ! elsif Server_ID (Interrupt) /= Null_Task then ! ! -- We need to use per-task lock. ! ! Task_Lock (Interrupt) := True; ! POP.Unlock (L'Access); ! POP.Write_Lock (Server_ID (Interrupt)); ! end if; ! end Lock_Interrupt; ! ! ---------------------- ! -- Unlock_Interrupt -- ! ---------------------- ! ! procedure Unlock_Interrupt ! (Self_ID : Task_ID; ! Interrupt : Interrupt_ID) ! is ! begin ! if Task_Lock (Interrupt) then ! POP.Unlock (Server_ID (Interrupt)); ! else ! POP.Unlock (L'Access); ! end if; ! ! Initialization.Undefer_Abort (Self_ID); ! end Unlock_Interrupt; ! ! ---------------------------------- ! -- Register_Interrupt_Handler -- ! ---------------------------------- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is New_Node_Ptr : R_Link; - begin -- This routine registers the Handler as usable for Dynamic -- Interrupt Handler. Routines attaching and detaching Handler --- 256,275 ---- Access_Hold : Server_Task_Access; -- variable used to allocate Server_Task using "new". ----------------------- -- Local Subprograms -- ----------------------- function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. ! -------------------------------- ! -- Register_Interrupt_Handler -- ! -------------------------------- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is New_Node_Ptr : R_Link; begin -- This routine registers the Handler as usable for Dynamic -- Interrupt Handler. Routines attaching and detaching Handler *************** package body System.Interrupts is *** 392,402 **** -- Is_Registered -- ------------------- - -- See if the Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - function Is_Registered (Handler : Parameterless_Handler) return Boolean is - type Fat_Ptr is record Object_Addr : System.Address; Handler_Addr : System.Address; --- 300,306 ---- *************** package body System.Interrupts is *** 528,535 **** 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" & --- 432,438 ---- 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" & *************** package body System.Interrupts is *** 556,563 **** (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" & --- 459,465 ---- (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" & *************** package body System.Interrupts is *** 582,589 **** procedure Detach_Handler (Interrupt : in Interrupt_ID; ! Static : in Boolean := False) ! is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & --- 484,490 ---- procedure Detach_Handler (Interrupt : in Interrupt_ID; ! Static : in Boolean := False) is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & *************** package body System.Interrupts is *** 591,597 **** end if; Interrupt_Manager.Detach_Handler (Interrupt, Static); - end Detach_Handler; --------------- --- 492,497 ---- *************** package body System.Interrupts is *** 622,628 **** E : Task_Entry_Index; Int_Ref : System.Address) is ! Interrupt : constant Interrupt_ID := Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); begin --- 522,528 ---- E : Task_Entry_Index; Int_Ref : System.Address) is ! Interrupt : constant Interrupt_ID := Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); begin *************** package body System.Interrupts is *** 677,685 **** ------------------ function Unblocked_By ! (Interrupt : Interrupt_ID) ! return System.Tasking.Task_ID ! is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & --- 577,583 ---- ------------------ function Unblocked_By ! (Interrupt : Interrupt_ID) return System.Tasking.Task_ID is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & *************** package body System.Interrupts is *** 723,731 **** task body Interrupt_Manager is ! ---------------------- ! -- Local Variables -- ! ---------------------- Intwait_Mask : aliased IMNG.Interrupt_Mask; Ret_Interrupt : Interrupt_ID; --- 621,629 ---- task body Interrupt_Manager is ! --------------------- ! -- Local Variables -- ! --------------------- Intwait_Mask : aliased IMNG.Interrupt_Mask; Ret_Interrupt : Interrupt_ID; *************** package body System.Interrupts is *** 756,770 **** 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. -- raise a program error. (propagate it to the caller). - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "An interrupt is already installed"); end if; --- 654,665 ---- 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. -- raise a program error. (propagate it to the caller). Raise_Exception (Program_Error'Identity, "An interrupt is already installed"); end if; *************** package body System.Interrupts is *** 777,783 **** -- may be detaching a static handler to restore a dynamic one. if not Restoration and then not Static - -- Tries to overwrite a static Interrupt Handler with a -- dynamic Handler --- 672,677 ---- *************** package body System.Interrupts is *** 788,794 **** or else not Is_Registered (New_Handler)) then - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "Trying to overwrite a static Interrupt Handler with a " & "dynamic Handler"); --- 682,687 ---- *************** package body System.Interrupts is *** 841,851 **** begin if User_Entry (Interrupt).T /= Null_Task then - -- In case we have an Interrupt Entry installed. -- raise a program error. (propagate it to the caller). - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "An interrupt entry is already installed"); end if; --- 734,742 ---- *************** package body System.Interrupts is *** 855,865 **** -- status of the current_Handler. if not Static and then User_Handler (Interrupt).Static then - -- Tries to detach a static Interrupt Handler. -- raise a program error. - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "Trying to detach a static Interrupt Handler"); end if; --- 746,754 ---- *************** package body System.Interrupts is *** 932,938 **** declare Old_Handler : Parameterless_Handler; - begin select --- 821,826 ---- *************** package body System.Interrupts is *** 942,951 **** Static : in Boolean; Restoration : in Boolean := False) do - Lock_Interrupt (Self_ID, Interrupt); Unprotected_Exchange_Handler (Old_Handler, New_Handler, Interrupt, Static, Restoration); - Unlock_Interrupt (Self_ID, Interrupt); end Attach_Handler; or accept Exchange_Handler --- 830,837 ---- *************** package body System.Interrupts is *** 954,972 **** Interrupt : in Interrupt_ID; Static : in Boolean) do - Lock_Interrupt (Self_ID, Interrupt); Unprotected_Exchange_Handler (Old_Handler, New_Handler, Interrupt, Static); - Unlock_Interrupt (Self_ID, Interrupt); end Exchange_Handler; or accept Detach_Handler (Interrupt : in Interrupt_ID; Static : in Boolean) do - Lock_Interrupt (Self_ID, Interrupt); Unprotected_Detach_Handler (Interrupt, Static); - Unlock_Interrupt (Self_ID, Interrupt); end Detach_Handler; or accept Bind_Interrupt_To_Entry --- 840,854 ---- *************** package body System.Interrupts is *** 974,988 **** E : Task_Entry_Index; Interrupt : Interrupt_ID) do - Lock_Interrupt (Self_ID, Interrupt); - -- if there is a binding already (either a procedure or an -- entry), raise Program_Error (propagate it to the caller). if User_Handler (Interrupt).H /= null or else User_Entry (Interrupt).T /= Null_Task then - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "A binding for this interrupt is already present"); end if; --- 856,867 ---- *************** package body System.Interrupts is *** 1013,1028 **** POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); end if; - - Unlock_Interrupt (Self_ID, Interrupt); end Bind_Interrupt_To_Entry; or accept Detach_Interrupt_Entries (T : Task_ID) do for I in Interrupt_ID'Range loop if not Is_Reserved (I) then - Lock_Interrupt (Self_ID, I); - if User_Entry (I).T = T then -- The interrupt should no longer be ignored if --- 892,903 ---- *************** package body System.Interrupts is *** 1033,1040 **** (T => Null_Task, E => Null_Task_Entry); IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (I)); end if; - - Unlock_Interrupt (Self_ID, I); end if; end loop; --- 908,913 ---- *************** package body System.Interrupts is *** 1062,1068 **** end select; exception - -- If there is a program error we just want to propagate it -- to the caller and do not want to stop this task. --- 935,940 ---- *************** package body System.Interrupts is *** 1070,1084 **** null; when others => ! pragma Assert ! (Shutdown ("Interrupt_Manager---exception not expected")); null; end; - end loop; - - pragma Assert (Shutdown ("Interrupt_Manager---should not get here")); - end Interrupt_Manager; ----------------- --- 942,951 ---- null; when others => ! pragma Assert (False); null; end; end loop; end Interrupt_Manager; ----------------- *************** package body System.Interrupts is *** 1130,1135 **** --- 997,1006 ---- -- from status change (Unblocked -> Blocked). If that is not -- the case, we should exceute the attached Procedure or Entry. + if Single_Lock then + POP.Lock_RTS; + end if; + POP.Write_Lock (Self_ID); if User_Handler (Interrupt).H = null *************** package body System.Interrupts is *** 1143,1149 **** Self_ID.Common.State := Runnable; else - Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access); Self_ID.Common.State := Runnable; --- 1014,1019 ---- *************** package body System.Interrupts is *** 1159,1167 **** --- 1029,1045 ---- POP.Unlock (Self_ID); + if Single_Lock then + POP.Unlock_RTS; + 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; *************** package body System.Interrupts is *** 1170,1191 **** POP.Unlock (Self_ID); System.Tasking.Rendezvous.Call_Simple (Tmp_ID, Tmp_Entry_Index, System.Null_Address); POP.Write_Lock (Self_ID); end if; end if; end if; POP.Unlock (Self_ID); System.Tasking.Initialization.Undefer_Abort (Self_ID); -- Undefer abort here to allow a window for this task -- to be aborted at the time of system shutdown. end loop; - - pragma Assert (Shutdown ("Server_Task---should not get here")); end Server_Task; ------------------------------------- --- 1048,1080 ---- POP.Unlock (Self_ID); + if Single_Lock then + POP.Unlock_RTS; + end if; + 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; POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + System.Tasking.Initialization.Undefer_Abort (Self_ID); -- Undefer abort here to allow a window for this task -- to be aborted at the time of system shutdown. end loop; end Server_Task; ------------------------------------- *************** package body System.Interrupts is *** 1238,1245 **** procedure Install_Handlers (Object : access Static_Interrupt_Protection; ! New_Handlers : in New_Handler_Array) ! is begin for N in New_Handlers'Range loop --- 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 *************** begin *** 1267,1278 **** Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - -- Initialize the lock L. - - Initialization.Defer_Abort (Self); - POP.Initialize_Lock (L'Access, POP.ATCB_Level); - Initialization.Undefer_Abort (Self); - -- During the elaboration of this package body we want RTS to -- inherit the interrupt mask from the Environment Task. --- 1155,1160 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vintman.adb gcc-3.3/gcc/ada/5vintman.adb *** gcc-3.2.3/gcc/ada/5vintman.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/5vintman.adb 2002-03-14 10:58:40.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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-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- -- *************** package body System.Interrupt_Management *** 50,57 **** use System.OS_Interface; use type unsigned_long; - type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; - --------------------------- -- Initialize_Interrupts -- --------------------------- --- 49,54 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vintman.ads gcc-3.3/gcc/ada/5vintman.ads *** gcc-3.2.3/gcc/ada/5vintman.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vintman.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vmastop.adb gcc-3.3/gcc/ada/5vmastop.adb *** gcc-3.2.3/gcc/ada/5vmastop.adb 2001-10-02 13:42:28.000000000 +0000 --- gcc-3.3/gcc/ada/5vmastop.adb 2002-03-14 10:58:40.000000000 +0000 *************** *** 7,15 **** -- B o d y -- -- (Version for Alpha/VMS) -- -- -- - -- $Revision: 1.1 $ -- -- ! -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 7,14 ---- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** package body System.Machine_State_Operat *** 65,77 **** end record; for ICB_Fflags_Bits_Type'Size use 24; - ICB_Fflags_Bits_Type_Init : constant ICB_Fflags_Bits_Type := - (ExceptIon_Frame => False, - Ast_Frame => False, - Bottom_Of_STACK => False, - Base_Frame => False, - Filler_1 => 0); - type ICB_Hdr_Quad_Type is record Context_Length : Unsigned_Longword; Fflags_Bits : ICB_Fflags_Bits_Type; --- 64,69 ---- *************** package body System.Machine_State_Operat *** 85,95 **** end record; for ICB_Hdr_Quad_Type'Size use 64; - ICB_Hdr_Quad_Type_Init : constant ICB_Hdr_Quad_Type := - (Context_Length => 0, - Fflags_Bits => ICB_Fflags_Bits_Type_Init, - Block_Version => 0); - type Invo_Context_Blk_Type is record -- -- The first quadword contains: --- 77,82 ---- *************** package body System.Machine_State_Operat *** 150,165 **** end record; for Invo_Context_Blk_Type'Size use 4352; - Invo_Context_Blk_Type_Init : constant Invo_Context_Blk_Type := - (Hdr_Quad => ICB_Hdr_Quad_Type_Init, - Procedure_Descriptor => (0, 0), - Program_Counter => 0, - Processor_Status => 0, - Ireg => (others => (0, 0)), - Freg => (others => (0, 0)), - System_Defined => (others => (0, 0)), - Filler_1 => (others => ASCII.NUL)); - subtype Invo_Handle_Type is Unsigned_Longword; type Invo_Handle_Access_Type is access all Invo_Handle_Type; --- 137,142 ---- *************** package body System.Machine_State_Operat *** 172,180 **** function To_Machine_State is new Unchecked_Conversion (System.Address, Machine_State); - function To_Code_Loc is new Unchecked_Conversion - (Unsigned_Longword, Code_Loc); - ---------------------------- -- Allocate_Machine_State -- ---------------------------- --- 149,154 ---- *************** package body System.Machine_State_Operat *** 244,254 **** ------------------------ procedure Free_Machine_State (M : in out Machine_State) is - procedure Gnat_Free (M : in Invo_Handle_Access_Type); - pragma Import (C, Gnat_Free, "__gnat_free"); - begin ! Gnat_Free (To_Invo_Handle_Access (M)); M := Machine_State (Null_Address); end Free_Machine_State; --- 218,225 ---- ------------------------ procedure Free_Machine_State (M : in out Machine_State) is begin ! Memory.Free (Address (M)); M := Machine_State (Null_Address); end Free_Machine_State; diff -Nrc3pad gcc-3.2.3/gcc/ada/5vosinte.adb gcc-3.3/gcc/ada/5vosinte.adb *** gcc-3.2.3/gcc/ada/5vosinte.adb 2001-10-02 13:42:28.000000000 +0000 --- gcc-3.3/gcc/ada/5vosinte.adb 2002-03-14 10:58:40.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2000 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vosinte.ads gcc-3.3/gcc/ada/5vosinte.ads *** gcc-3.2.3/gcc/ada/5vosinte.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vosinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vosprim.adb gcc-3.3/gcc/ada/5vosprim.adb *** gcc-3.2.3/gcc/ada/5vosprim.adb 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vosprim.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vosprim.ads gcc-3.3/gcc/ada/5vosprim.ads *** gcc-3.2.3/gcc/ada/5vosprim.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vosprim.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vparame.ads gcc-3.3/gcc/ada/5vparame.ads *** gcc-3.2.3/gcc/ada/5vparame.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vparame.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** pragma Pure (Parameters); *** 133,136 **** --- 132,190 ---- 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 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 := 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); + + -------------------- + -- 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.2.3/gcc/ada/5vsystem.ads gcc-3.3/gcc/ada/5vsystem.ads *** gcc-3.2.3/gcc/ada/5vsystem.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vsystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (OpenVMS DEC Threads Version) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 92,118 **** -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 91,104 ---- -- 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 *************** private *** 130,137 **** --- 116,126 ---- -- 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 := 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5vtaprop.adb gcc-3.3/gcc/ada/5vtaprop.adb *** gcc-3.2.3/gcc/ada/5vtaprop.adb 2001-12-16 01:13:29.000000000 +0000 --- gcc-3.3/gcc/ada/5vtaprop.adb 2002-03-14 10:58:41.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 29,36 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- 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). -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 94,101 **** ATCB_Key : aliased pthread_key_t; -- Key used to find the Ada Task_ID associated with a thread ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 92,101 ---- 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. *************** package body System.Task_Primitives.Oper *** 170,176 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as All_Tasks_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. --- 170,176 ---- -- 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. *************** package body System.Task_Primitives.Oper *** 244,250 **** procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L.L'Access); pragma Assert (Result = 0); --- 244,249 ---- *************** package body System.Task_Primitives.Oper *** 252,258 **** procedure Finalize_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); --- 251,256 ---- *************** package body System.Task_Primitives.Oper *** 289,308 **** -- Set_Priority (Self_ID, System.Any_Priority (L.Prio)); end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Write_Lock; --------------- --- 287,310 ---- -- Set_Priority (Self_ID, System.Any_Priority (L.Prio)); end Write_Lock; ! procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) ! is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); ! end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Write_Lock; --------------- *************** package body System.Task_Primitives.Oper *** 320,359 **** procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_unlock (L.L'Access); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Unlock; ! ------------- ! -- Sleep -- ! ------------- ! procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; - begin ! pragma Assert (Self_ID = Self); ! Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access); -- EINTR is not considered a failure. pragma Assert (Result = 0 or else Result = EINTR); --- 322,368 ---- procedure Unlock (L : access Lock) is Result : Interfaces.C.int; begin Result := pthread_mutex_unlock (L.L'Access); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); ! end if; end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Unlock; ! ----------- ! -- Sleep -- ! ----------- ! procedure Sleep ! (Self_ID : 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. pragma Assert (Result = 0 or else Result = EINTR); *************** package body System.Task_Primitives.Oper *** 369,378 **** -- 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; --- 378,383 ---- *************** package body System.Task_Primitives.Oper *** 392,398 **** Sleep_Time := To_OS_Time (Time, Mode); if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level ! or else Self_ID.Pending_Priority_Change then return; end if; --- 397,403 ---- Sleep_Time := To_OS_Time (Time, Mode); if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level ! or else Self_ID.Pending_Priority_Change then return; end if; *************** package body System.Task_Primitives.Oper *** 407,414 **** raise Storage_Error; end if; ! Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access); if not Self_ID.Common.LL.AST_Pending then Timedout := True; --- 412,427 ---- raise Storage_Error; end if; ! 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; ! ! Yielded := True; if not Self_ID.Common.LL.AST_Pending then Timedout := True; *************** package body System.Task_Primitives.Oper *** 416,456 **** Sys_Cantim (Status, To_Address (Self_ID), 0); pragma Assert ((Status and 1) = 1); 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 Sleep_Time : OS_Time; Result : Interfaces.C.int; Status : Cond_Value_Type; 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; Write_Lock (Self_ID); ! if not (Time = 0.0 and then Mode = Relative) then ! Sleep_Time := To_OS_Time (Time, Mode); if Mode = Relative or else OS_Clock < Sleep_Time then - Self_ID.Common.State := Delay_Sleep; Self_ID.Common.LL.AST_Pending := True; --- 429,466 ---- Sys_Cantim (Status, To_Address (Self_ID), 0); pragma Assert ((Status and 1) = 1); end if; end Timed_Sleep; ----------------- -- Timed_Delay -- ----------------- procedure Timed_Delay ! (Self_ID : Task_ID; ! Time : Duration; ! Mode : ST.Delay_Modes) is Sleep_Time : OS_Time; Result : Interfaces.C.int; Status : Cond_Value_Type; + Yielded : Boolean := False; 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! ! ! if Single_Lock then ! Lock_RTS; ! end if; SSL.Abort_Defer.all; Write_Lock (Self_ID); ! if Time /= 0.0 or else Mode /= Relative then Sleep_Time := To_OS_Time (Time, Mode); if Mode = Relative or else OS_Clock < Sleep_Time then Self_ID.Common.State := Delay_Sleep; Self_ID.Common.LL.AST_Pending := True; *************** package body System.Task_Primitives.Oper *** 475,494 **** exit; end if; ! Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access); ! exit when not Self_ID.Common.LL.AST_Pending; end loop; Self_ID.Common.State := Runnable; - end if; end if; Unlock (Self_ID); ! Result := sched_yield; SSL.Abort_Undefer.all; end Timed_Delay; --- 485,517 ---- exit; end if; ! 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; ! Yielded := True; + exit when not Self_ID.Common.LL.AST_Pending; end loop; Self_ID.Common.State := Runnable; end if; end if; Unlock (Self_ID); ! ! if Single_Lock then ! Unlock_RTS; ! end if; ! ! if not Yielded then ! Result := sched_yield; ! end if; ! SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 514,520 **** 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); --- 537,542 ---- *************** package body System.Task_Primitives.Oper *** 526,532 **** procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; - begin if Do_Yield then Result := sched_yield; --- 548,553 ---- *************** package body System.Task_Primitives.Oper *** 538,552 **** ------------------ 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; begin T.Common.Current_Priority := Prio; ! Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); if Time_Slice_Val > 0 then Result := pthread_setschedparam --- 559,573 ---- ------------------ 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; begin T.Common.Current_Priority := Prio; ! Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); if Time_Slice_Val > 0 then Result := pthread_setschedparam *************** package body System.Task_Primitives.Oper *** 579,585 **** procedure Enter_Task (Self_ID : Task_ID) is Result : Interfaces.C.int; - begin Self_ID.Common.LL.Thread := pthread_self; --- 600,605 ---- *************** package body System.Task_Primitives.Oper *** 591,605 **** Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); pragma Assert (Result = 0); ! Lock_All_Tasks_List; ! for I in Known_Tasks'Range loop ! if Known_Tasks (I) = null then ! Known_Tasks (I) := Self_ID; ! Self_ID.Known_Tasks_Index := I; exit; end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 611,627 ---- Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); pragma Assert (Result = 0); ! Lock_RTS; ! ! for J in Known_Tasks'Range loop ! if Known_Tasks (J) = null then ! Known_Tasks (J) := Self_ID; ! Self_ID.Known_Tasks_Index := J; exit; end if; end loop; ! ! Unlock_RTS; end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 621,673 **** Cond_Attr : aliased pthread_condattr_t; begin ! Result := pthread_mutexattr_init (Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! ! if Result /= 0 then ! Succeeded := False; ! return; ! end if; ! ! -- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes. ! -- Result := pthread_mutexattr_settype_np ! -- (Mutex_Attr'Access, PTHREAD_MUTEX_ERRORCHECK_NP); ! -- pragma Assert (Result = 0); ! ! -- 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); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; end if; - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! Succeeded := False; ! return; end if; - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - if Result = 0 then Succeeded := True; Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T; --- 643,676 ---- 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); ! 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; Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T; *************** package body System.Task_Primitives.Oper *** 676,683 **** Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address); else ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); Succeeded := False; end if; --- 679,689 ---- Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address); 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; *************** package body System.Task_Primitives.Oper *** 777,789 **** (Exc_Stack_T, Exc_Stack_Ptr_T); begin ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); 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 (T.Common.LL.Exc_Stack_Ptr); Free (Tmp); end Finalize_TCB; --- 783,800 ---- (Exc_Stack_T, Exc_Stack_Ptr_T); begin ! if not Single_Lock then ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; ! Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); + if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; end if; + Free (T.Common.LL.Exc_Stack_Ptr); Free (Tmp); end Finalize_TCB; *************** package body System.Task_Primitives.Oper *** 851,873 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 862,884 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 899,905 **** begin Environment_Task_ID := Environment_Task; ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); -- Initialize the lock used to synchronize chain of all ATCBs. Enter_Task (Environment_Task); --- 910,916 ---- 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); diff -Nrc3pad gcc-3.2.3/gcc/ada/5vtaspri.ads gcc-3.3/gcc/ada/5vtaspri.ads *** gcc-3.2.3/gcc/ada/5vtaspri.ads 2002-05-04 03:27:16.000000000 +0000 --- gcc-3.3/gcc/ada/5vtaspri.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vtpopde.adb gcc-3.3/gcc/ada/5vtpopde.adb *** gcc-3.2.3/gcc/ada/5vtpopde.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/5vtpopde.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 2,15 **** -- -- -- 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 -- -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.2 $ -- -- ! -- 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,13 ---- -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- -- -- -- 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- -- *************** *** 33,43 **** -- 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; --- 31,43 ---- -- 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; *************** package body System.Task_Primitives.Oper *** 45,60 **** use System.Aux_DEC; use type Interfaces.C.int; ! -- The FAB_RAB_Type specifieds 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 CTX : Unsigned_Longword; end record; ! for FAB_RAB_Type use ! record CTX at 24 range 0 .. 31; end record; --- 45,59 ---- 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 CTX : Unsigned_Longword; end record; ! for FAB_RAB_Type use record CTX at 24 range 0 .. 31; end record; *************** package body System.Task_Primitives.Oper *** 80,87 **** --------------------------- procedure Interrupt_AST_Handler (ID : Address) is ! Result : Interfaces.C.int; ! AST_Self_ID : Task_ID := To_Task_Id (ID); begin Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); pragma Assert (Result = 0); --- 79,87 ---- --------------------------- procedure Interrupt_AST_Handler (ID : Address) is ! Result : Interfaces.C.int; ! AST_Self_ID : Task_ID := To_Task_Id (ID); ! begin Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 92,99 **** --------------------- procedure RMS_AST_Handler (ID : Address) is ! AST_Self_ID : Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX); ! Result : Interfaces.C.int; begin AST_Self_ID.Common.LL.AST_Pending := False; Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); --- 92,100 ---- --------------------- procedure RMS_AST_Handler (ID : Address) is ! AST_Self_ID : Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX); ! Result : Interfaces.C.int; ! begin AST_Self_ID.Common.LL.AST_Pending := False; Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); *************** package body System.Task_Primitives.Oper *** 106,111 **** --- 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); *************** package body System.Task_Primitives.Oper *** 116,123 **** ------------------------- procedure Starlet_AST_Handler (ID : Address) is ! Result : Interfaces.C.int; ! AST_Self_ID : Task_ID := To_Task_Id (ID); begin AST_Self_ID.Common.LL.AST_Pending := False; Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); --- 118,126 ---- ------------------------- procedure Starlet_AST_Handler (ID : Address) is ! Result : Interfaces.C.int; ! AST_Self_ID : Task_ID := To_Task_Id (ID); ! begin AST_Self_ID.Common.LL.AST_Pending := False; Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); *************** package body System.Task_Primitives.Oper *** 130,141 **** --- 133,147 ---- 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 Sleep (Synch_Self_ID, AST_Server_Sleep); end loop; + Synch_Self_ID.Common.State := Runnable; Unlock (Synch_Self_ID); end Task_Synch; diff -Nrc3pad gcc-3.2.3/gcc/ada/5vtpopde.ads gcc-3.3/gcc/ada/5vtpopde.ads *** gcc-3.2.3/gcc/ada/5vtpopde.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/5vtpopde.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,13 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 2000 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5vvaflop.adb gcc-3.3/gcc/ada/5vvaflop.adb *** gcc-3.2.3/gcc/ada/5vvaflop.adb 2002-05-04 03:27:17.000000000 +0000 --- gcc-3.3/gcc/ada/5vvaflop.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2000 Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5wgloloc.adb gcc-3.3/gcc/ada/5wgloloc.adb *** gcc-3.2.3/gcc/ada/5wgloloc.adb 2001-10-02 13:42:28.000000000 +0000 --- gcc-3.3/gcc/ada/5wgloloc.adb 2002-03-14 10:58:41.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5wintman.adb gcc-3.3/gcc/ada/5wintman.adb *** gcc-3.2.3/gcc/ada/5wintman.adb 2002-05-04 03:27:17.000000000 +0000 --- gcc-3.3/gcc/ada/5wintman.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5wmemory.adb gcc-3.3/gcc/ada/5wmemory.adb *** gcc-3.2.3/gcc/ada/5wmemory.adb 2002-05-04 03:27:17.000000000 +0000 --- gcc-3.3/gcc/ada/5wmemory.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body System.Memory is *** 214,220 **** Result := c_realloc (Ptr, Actual_Size); if Result /= System.Null_Address then ! Available_Memory := Available_Memory + Old_Size - msize (Ptr); end if; Unlock_Task.all; --- 213,219 ---- Result := c_realloc (Ptr, Actual_Size); if Result /= System.Null_Address then ! Available_Memory := Available_Memory + Old_Size - msize (Result); end if; Unlock_Task.all; diff -Nrc3pad gcc-3.2.3/gcc/ada/5wosinte.ads gcc-3.3/gcc/ada/5wosinte.ads *** gcc-3.2.3/gcc/ada/5wosinte.ads 2002-05-04 03:27:17.000000000 +0000 --- gcc-3.3/gcc/ada/5wosinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5wosprim.adb gcc-3.3/gcc/ada/5wosprim.adb *** gcc-3.2.3/gcc/ada/5wosprim.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/5wosprim.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5wsystem.ads gcc-3.3/gcc/ada/5wsystem.ads *** gcc-3.2.3/gcc/ada/5wsystem.ads 2002-05-04 03:27:17.000000000 +0000 --- gcc-3.3/gcc/ada/5wsystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,15 **** -- S p e c -- -- (NT Version) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 92,118 **** -- Priority-related Declarations (RM D.1) ! Max_Priority : constant Positive := 30; ! Max_Interrupt_Priority : constant Positive := 31; ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 91,104 ---- -- 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 *************** private *** 130,137 **** --- 116,126 ---- -- 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; *************** private *** 198,201 **** --- 187,197 ---- Interrupt_Priority => 15); + pragma Linker_Options ("-Wl,--stack=0x2000000"); + -- This is used to change the default stack (32 MB) size for non tasking + -- programs. We change this value for GNAT on Windows here because the + -- binutils on this platform have switched to a too low value for Ada + -- programs. Note that we also set the stack size for tasking programs in + -- System.Task_Primitives.Operations. + end System; diff -Nrc3pad gcc-3.2.3/gcc/ada/5wtaprop.adb gcc-3.3/gcc/ada/5wtaprop.adb *** gcc-3.2.3/gcc/ada/5wtaprop.adb 2002-05-04 03:27:17.000000000 +0000 --- gcc-3.3/gcc/ada/5wtaprop.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- 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,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- -- *************** package body System.Task_Primitives.Oper *** 90,96 **** use System.Parameters; use System.OS_Primitives; ! pragma Linker_Options ("-Xlinker --stack=0x800000,0x1000"); package SSL renames System.Soft_Links; --- 89,98 ---- use System.Parameters; use System.OS_Primitives; ! pragma Link_With ("-Xlinker --stack=0x800000,0x1000"); ! -- Change the stack size (8 MB) for tasking programs on Windows. This ! -- permit to have more than 30 tasks running at the same time. Note that ! -- we set the stack size for non tasking programs on System unit. package SSL renames System.Soft_Links; *************** package body System.Task_Primitives.Oper *** 101,108 **** Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); --- 103,112 ---- Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. ! 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 Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); *************** package body System.Task_Primitives.Oper *** 132,138 **** 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. --- 136,142 ---- 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. *************** package body System.Task_Primitives.Oper *** 183,189 **** -- 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; --- 187,193 ---- -- 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; *************** package body System.Task_Primitives.Oper *** 262,268 **** -- Must not unlock until Next_ATCB is again allocated. ! Unlock (All_Tasks_L'Access); return Self_ID; end New_Fake_ATCB; --- 266,272 ---- -- Must not unlock until Next_ATCB is again allocated. ! Unlock_RTS; return Self_ID; end New_Fake_ATCB; *************** package body System.Task_Primitives.Oper *** 474,480 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is handled. ! -- Other mutexes (such as All_Tasks_Lock, Memory_Lock...) used in -- the RTS is initialized before any status change of RTS. -- Therefore raising Storage_Error in the following routines -- should be able to be handled safely. --- 478,484 ---- -- 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 -- should be able to be handled safely. *************** package body System.Task_Primitives.Oper *** 525,539 **** Ceiling_Violation := False; end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is begin ! EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); end Write_Lock; procedure Write_Lock (T : Task_ID) is begin ! EnterCriticalSection ! (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); end Write_Lock; --------------- --- 529,548 ---- Ceiling_Violation := False; 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); ! end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is begin ! if not Single_Lock then ! EnterCriticalSection ! (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); ! end if; end Write_Lock; --------------- *************** package body System.Task_Primitives.Oper *** 554,568 **** LeaveCriticalSection (L.Mutex'Access); end Unlock; ! procedure Unlock (L : access RTS_Lock) is begin ! LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); end Unlock; procedure Unlock (T : Task_ID) is begin ! LeaveCriticalSection ! (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); end Unlock; ----------- --- 563,581 ---- LeaveCriticalSection (L.Mutex'Access); end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is begin ! if not Single_Lock or else Global_Lock then ! LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); ! end if; end Unlock; procedure Unlock (T : Task_ID) is begin ! if not Single_Lock then ! LeaveCriticalSection ! (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); ! end if; end Unlock; ----------- *************** package body System.Task_Primitives.Oper *** 575,581 **** begin pragma Assert (Self_ID = Self); ! Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); if Self_ID.Deferral_Level = 0 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level --- 588,598 ---- begin pragma Assert (Self_ID = Self); ! if Single_Lock then ! Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); ! else ! Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); ! end if; if Self_ID.Deferral_Level = 0 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level *************** package body System.Task_Primitives.Oper *** 610,616 **** begin Timedout := True; ! Yielded := False; if Mode = Relative then Rel_Time := Time; --- 627,633 ---- begin Timedout := True; ! Yielded := False; if Mode = Relative then Rel_Time := Time; *************** package body System.Task_Primitives.Oper *** 625,632 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level or else Self_ID.Pending_Priority_Change; ! Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result); exit when Abs_Time <= Monotonic_Clock; --- 642,654 ---- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level or else Self_ID.Pending_Priority_Change; ! if Single_Lock then ! Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, ! Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result); ! else ! Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result); ! end if; exit when Abs_Time <= Monotonic_Clock; *************** package body System.Task_Primitives.Oper *** 659,667 **** 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; Write_Lock (Self_ID); if Mode = Relative then --- 681,694 ---- 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; + Write_Lock (Self_ID); if Mode = Relative then *************** package body System.Task_Primitives.Oper *** 684,691 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result); exit when Abs_Time <= Monotonic_Clock; --- 711,723 ---- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! if Single_Lock then ! Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, ! Single_RTS_Lock'Access, Rel_Time, Timedout, Result); ! else ! Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result); ! end if; exit when Abs_Time <= Monotonic_Clock; *************** package body System.Task_Primitives.Oper *** 696,701 **** --- 728,738 ---- end if; Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + Yield; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 833,839 **** Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; ! Lock_All_Tasks_List; for J in Known_Tasks'Range loop if Known_Tasks (J) = null then --- 870,876 ---- Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; ! Lock_RTS; for J in Known_Tasks'Range loop if Known_Tasks (J) = null then *************** package body System.Task_Primitives.Oper *** 843,849 **** end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 880,886 ---- end if; end loop; ! Unlock_RTS; end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 855,868 **** 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 Initialize_Cond (Self_ID.Common.LL.CV'Access); ! Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); Succeeded := True; end Initialize_TCB; --- 892,909 ---- 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 Initialize_Cond (Self_ID.Common.LL.CV'Access); ! ! if not Single_Lock then ! Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); ! end if; ! Succeeded := True; end Initialize_TCB; *************** package body System.Task_Primitives.Oper *** 879,890 **** is hTask : HANDLE; TaskId : aliased DWORD; - - -- ??? The fact that we can't use PVOID because the compiler - -- gives a "PVOID is not visible" error is a GNAT bug. - -- The strange thing is that the file compiles fine during a regular - -- build. - pTaskParameter : System.OS_Interface.PVOID; dwStackSize : DWORD; Result : DWORD; --- 920,925 ---- *************** package body System.Task_Primitives.Oper *** 951,957 **** Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin ! Finalize_Lock (T.Common.LL.L'Access); Finalize_Cond (T.Common.LL.CV'Access); if T.Known_Tasks_Index /= -1 then --- 986,995 ---- Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin ! if not Single_Lock then ! Finalize_Lock (T.Common.LL.L'Access); ! end if; ! Finalize_Cond (T.Common.LL.CV'Access); if T.Known_Tasks_Index /= -1 then *************** package body System.Task_Primitives.Oper *** 996,1018 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ---------------- -- Initialize -- --- 1034,1056 ---- 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; ---------------- -- Initialize -- *************** package body System.Task_Primitives.Oper *** 1032,1038 **** -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); Environment_Task.Common.LL.Thread := GetCurrentThread; Enter_Task (Environment_Task); --- 1070,1076 ---- -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); Environment_Task.Common.LL.Thread := GetCurrentThread; Enter_Task (Environment_Task); diff -Nrc3pad gcc-3.2.3/gcc/ada/5wtaspri.ads gcc-3.3/gcc/ada/5wtaspri.ads *** gcc-3.2.3/gcc/ada/5wtaspri.ads 2002-05-04 03:27:17.000000000 +0000 --- gcc-3.3/gcc/ada/5wtaspri.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5ysystem.ads gcc-3.3/gcc/ada/5ysystem.ads *** gcc-3.2.3/gcc/ada/5ysystem.ads 2002-05-04 03:27:17.000000000 +0000 --- gcc-3.3/gcc/ada/5ysystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 5,15 **** -- S Y S T E M -- -- -- -- S p e c -- ! -- (VXWORKS Version PPC, Sparc64) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 *************** pragma Pure (System); *** 88,127 **** -- Other System-Dependent Declarations type Bit_Order is (High_Order_First, Low_Order_First); ! Default_Bit_Order : constant Bit_Order := ! Bit_Order'Val (Standard'Default_Bit_Order); -- 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_Interrupt_Priority : constant Positive := 255; ! Max_Priority : constant Positive := 245; ! ! subtype Any_Priority is Integer ! range 0 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 87,112 ---- -- 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 *************** private *** 139,146 **** --- 124,134 ---- -- 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; 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5zinterr.adb gcc-3.3/gcc/ada/5zinterr.adb *** gcc-3.2.3/gcc/ada/5zinterr.adb 2002-05-04 03:27:18.000000000 +0000 --- gcc-3.3/gcc/ada/5zinterr.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- 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,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- -- *************** *** 45,57 **** -- hardware interrupts, which may be masked or unmasked using routined -- interfaced to the relevant VxWorks system calls. - -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any - -- other low-level interface that changes the signal action or - -- signal mask needs careful consideration. - -- One may achieve the effect of system calls first masking RTS blocked - -- (by calling Block_Interrupt) for the signal under consideration. - -- This will make all the tasks in RTS blocked for the signal. - -- Once we associate a Signal_Server_Task with an signal, the task never -- goes away, and we never remove the association. On the other hand, it -- is more convenient to terminate an associated Interrupt_Server_Task --- 44,49 ---- *************** *** 71,85 **** -- service requests are ensured via user calls to the Interrupt_Manager -- entries. ! -- This is the VxWorks version of this package, supporting both signals ! -- and vectored hardware interrupts. with Unchecked_Conversion; with System.OS_Interface; use System.OS_Interface; - with System.VxWorks; - with Interfaces.VxWorks; with Ada.Task_Identification; --- 63,75 ---- -- service requests are ensured via user calls to the Interrupt_Manager -- entries. ! -- This is the VxWorks version of this package, supporting vectored hardware ! -- interrupts. with Unchecked_Conversion; with System.OS_Interface; use System.OS_Interface; with Interfaces.VxWorks; with Ada.Task_Identification; *************** with Ada.Task_Identification; *** 88,126 **** with Ada.Exceptions; -- used for Raise_Exception - with System.Task_Primitives; - -- used for RTS_Lock - -- Self - - with System.Interrupt_Management; - -- used for Reserve - -- Interrupt_ID - -- Interrupt_Mask - -- Abort_Task_Interrupt - - with System.Interrupt_Management.Operations; - -- used for Thread_Block_Interrupt - -- Thread_Unblock_Interrupt - -- Install_Default_Action - -- Install_Ignore_Action - -- Copy_Interrupt_Mask - -- Set_Interrupt_Mask - -- Empty_Interrupt_Mask - -- Fill_Interrupt_Mask - -- Add_To_Interrupt_Mask - -- Delete_From_Interrupt_Mask - -- Interrupt_Wait - -- Interrupt_Self_Process - -- Get_Interrupt_Mask - -- Set_Interrupt_Mask - -- IS_Member - -- Environment_Mask - -- All_Tasks_Mask - pragma Elaborate_All (System.Interrupt_Management.Operations); - - with System.Error_Reporting; - -- used for Shutdown - with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock --- 78,83 ---- *************** with System.Task_Primitives.Operations; *** 129,137 **** -- Sleep -- Initialize_Lock - with System.Task_Primitives.Interrupt_Operations; - -- used for Set_Interrupt_ID - with System.Storage_Elements; -- used for To_Address -- To_Integer --- 86,91 ---- *************** with System.Tasking.Rendezvous; *** 151,171 **** -- used for Call_Simple pragma Elaborate_All (System.Tasking.Rendezvous); - with System.Tasking.Initialization; - -- used for Defer_Abort - -- Undefer_Abort - package body System.Interrupts is use Tasking; - use System.Error_Reporting; 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; - package IMOP renames System.Interrupt_Management.Operations; function To_Ada is new Unchecked_Conversion (System.Tasking.Task_ID, Ada.Task_Identification.Task_Id); --- 105,117 ---- *************** package body System.Interrupts is *** 177,188 **** -- Local Tasks -- ----------------- ! -- WARNING: System.Tasking.Utilities performs calls to this task -- with low-level constructs. Do not change this spec without synchro- -- nizing it. task Interrupt_Manager is ! entry Initialize (Mask : IMNG.Interrupt_Mask); entry Attach_Handler (New_Handler : Parameterless_Handler; --- 123,134 ---- -- Local Tasks -- ----------------- ! -- WARNING: System.Tasking.Stages performs calls to this task -- with low-level constructs. Do not change this spec without synchro- -- nizing it. task Interrupt_Manager is ! entry Detach_Interrupt_Entries (T : Task_ID); entry Attach_Handler (New_Handler : Parameterless_Handler; *************** package body System.Interrupts is *** 205,222 **** E : Task_Entry_Index; Interrupt : Interrupt_ID); - entry Detach_Interrupt_Entries (T : Task_ID); - pragma Interrupt_Priority (System.Interrupt_Priority'First); end Interrupt_Manager; - task type Signal_Server_Task (Interrupt : Interrupt_ID) is - pragma Interrupt_Priority (System.Interrupt_Priority'First + 1); - end Signal_Server_Task; - -- Server task for signal handling - - type Signal_Task_Access is access Signal_Server_Task; - task type Interrupt_Server_Task (Interrupt : Interrupt_ID; Int_Sema : SEM_ID) is -- Server task for vectored hardware interrupt handling --- 151,159 ---- *************** package body System.Interrupts is *** 274,306 **** -- is needed to determine whether to create a new Server_Task. Semaphore_ID_Map : array ! (Interrupt_ID range 0 .. System.VxWorks.Num_HW_Interrupts) of SEM_ID := ! (others => 0); -- Array of binary semaphores associated with vectored interrupts -- Note that the last bound should be Max_HW_Interrupt, but this will raise -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes -- instead. - Signal_Access_Hold : Signal_Task_Access; - -- Variable for allocating a Signal_Server_Task - Interrupt_Access_Hold : Interrupt_Task_Access; -- Variable for allocating an Interrupt_Server_Task - L : aliased PRI.RTS_Lock; - -- L protects the contents of the above tables for interrupts / signals - -- for which Server_ID (I) = Null_Task. - -- - -- If Server_ID (I) /= Null_Task then protection is via the - -- per-task (TCB) lock of Server_ID (I). - -- - -- For deadlock prevention, L should not be locked after - -- any other lock is held, hence we use PO_Level which is the highest - -- lock level for error checking. - - Task_Lock : array (Interrupt_ID) of Boolean := (others => False); - -- Booleans indicating whether the per task lock is used - Default_Handler : array (HW_Interrupt) of Interfaces.VxWorks.VOIDFUNCPTR; -- Vectored interrupt handlers installed prior to program startup. -- These are saved only when the umbrella handler is installed for --- 211,226 ---- -- is needed to determine whether to create a new Server_Task. Semaphore_ID_Map : array ! (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) ! of SEM_ID := (others => 0); -- Array of binary semaphores associated with vectored interrupts -- Note that the last bound should be Max_HW_Interrupt, but this will raise -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes -- instead. Interrupt_Access_Hold : Interrupt_Task_Access; -- Variable for allocating an Interrupt_Server_Task Default_Handler : array (HW_Interrupt) of Interfaces.VxWorks.VOIDFUNCPTR; -- Vectored interrupt handlers installed prior to program startup. -- These are saved only when the umbrella handler is installed for *************** package body System.Interrupts is *** 318,342 **** -- Unbind the handlers for hardware interrupt server tasks at program -- termination. - procedure Lock_Interrupt - (Self_ID : Task_ID; - Interrupt : Interrupt_ID); - -- Protect the tables using L or the per-task lock. Set the Boolean - -- value Task_Lock if the lock is made using per-task lock. - -- This information is needed so that Unlock_Interrupt - -- performs unlocking on the same lock. The situation we are preventing - -- is, for example, when Attach_Handler is called for the first time - -- we lock L and create an Server_Task. For a matching unlocking, if we - -- rely on the fact that there is a Server_Task, we will unlock the - -- per-task lock. - - procedure Unlock_Interrupt - (Self_ID : Task_ID; - Interrupt : Interrupt_ID); - -- Unlock interrupt previously locked by Lock_Interrupt - function Is_Registered (Handler : Parameterless_Handler) return Boolean; ! -- Needs comment ??? procedure Notify_Interrupt (Param : System.Address); -- Umbrella handler for vectored interrupts (not signals) --- 238,246 ---- -- Unbind the handlers for hardware interrupt server tasks at program -- termination. function Is_Registered (Handler : Parameterless_Handler) return Boolean; ! -- See if Handler has been "pragma"ed using Interrupt_Handler. ! -- Always consider a null handler as registered. procedure Notify_Interrupt (Param : System.Address); -- Umbrella handler for vectored interrupts (not signals) *************** package body System.Interrupts is *** 350,358 **** -- Install the runtime umbrella handler for a vectored hardware -- interrupt - function To_Signal (S : Interrupt_ID) return IMNG.Interrupt_ID; - -- Convert interrupt ID to signal number. - procedure Unimplemented (Feature : String); pragma No_Return (Unimplemented); -- Used to mark a call to an unimplemented function. Raises Program_Error --- 254,259 ---- *************** package body System.Interrupts is *** 373,380 **** procedure Attach_Handler (New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; ! Static : Boolean := False) ! is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); --- 274,280 ---- procedure Attach_Handler (New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; ! Static : Boolean := False) is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); *************** package body System.Interrupts is *** 394,400 **** Int_Ref : System.Address) is Interrupt : constant Interrupt_ID := ! Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); begin Check_Reserved_Interrupt (Interrupt); --- 294,300 ---- Int_Ref : System.Address) is Interrupt : constant Interrupt_ID := ! Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); begin Check_Reserved_Interrupt (Interrupt); *************** package body System.Interrupts is *** 430,438 **** --------------------- function Current_Handler ! (Interrupt : Interrupt_ID) ! return Parameterless_Handler ! is begin Check_Reserved_Interrupt (Interrupt); --- 330,336 ---- --------------------- function Current_Handler ! (Interrupt : Interrupt_ID) return Parameterless_Handler is begin Check_Reserved_Interrupt (Interrupt); *************** package body System.Interrupts is *** 456,463 **** procedure Detach_Handler (Interrupt : Interrupt_ID; ! Static : Boolean := False) ! is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Detach_Handler (Interrupt, Static); --- 354,360 ---- procedure Detach_Handler (Interrupt : Interrupt_ID; ! Static : Boolean := False) is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Detach_Handler (Interrupt, Static); *************** package body System.Interrupts is *** 488,495 **** (Old_Handler : out Parameterless_Handler; New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; ! Static : Boolean := False) ! is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Exchange_Handler --- 385,391 ---- (Old_Handler : out Parameterless_Handler; New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; ! Static : Boolean := False) is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Exchange_Handler *************** package body System.Interrupts is *** 524,533 **** -- Finalize_Interrupt_Servers -- -------------------------------- ! -- Restore default handlers for interrupt servers. Signal servers ! -- restore the default handlers when they're aborted. This is called ! -- by the Interrupt_Manager task when it receives the abort signal ! -- during program finalization. procedure Finalize_Interrupt_Servers is begin --- 420,428 ---- -- Finalize_Interrupt_Servers -- -------------------------------- ! -- 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 *************** package body System.Interrupts is *** 553,569 **** ------------------------------------- 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; --- 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; *************** package body System.Interrupts is *** 627,638 **** 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 --- 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 *************** package body System.Interrupts is *** 691,699 **** -- Is_Registered -- ------------------- - -- See if Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - function Is_Registered (Handler : Parameterless_Handler) return Boolean is type Fat_Ptr is record Object_Addr : System.Address; --- 581,586 ---- *************** package body System.Interrupts is *** 724,730 **** end loop; return False; - end Is_Registered; ----------------- --- 611,616 ---- *************** package body System.Interrupts is *** 733,795 **** function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is begin ! if Interrupt < System.VxWorks.Num_HW_Interrupts then ! return False; ! else ! return IMNG.Reserve (To_Signal (Interrupt)); ! end if; end Is_Reserved; ! -------------------- ! -- Lock_Interrupt -- ! -------------------- ! ! -- ????? ! -- This package has been modified several times. ! -- Do we still need this fancy locking scheme, now that more operations ! -- are entries of the interrupt manager task? ! -- ????? ! -- More likely, we will need to convert one or more entry calls to ! -- protected operations, because presently we are violating locking order ! -- rules by calling a task entry from within the runtime system. ! ! procedure Lock_Interrupt ! (Self_ID : Task_ID; ! Interrupt : Interrupt_ID) is ! begin ! Initialization.Defer_Abort (Self_ID); ! ! POP.Write_Lock (L'Access); ! ! if Task_Lock (Interrupt) then ! pragma Assert (Server_ID (Interrupt) /= null, ! "Task_Lock is true for null server task"); ! pragma Assert ! (not Ada.Task_Identification.Is_Terminated ! (To_Ada (Server_ID (Interrupt))), ! "Attempt to lock per task lock of terminated server: " & ! "Task_Lock => True"); ! ! POP.Unlock (L'Access); ! POP.Write_Lock (Server_ID (Interrupt)); ! ! elsif Server_ID (Interrupt) /= Null_Task then ! pragma Assert ! (not Ada.Task_Identification.Is_Terminated ! (To_Ada (Server_ID (Interrupt))), ! "Attempt to lock per task lock of terminated server: " & ! "Task_Lock => False"); ! ! Task_Lock (Interrupt) := True; ! POP.Unlock (L'Access); ! POP.Write_Lock (Server_ID (Interrupt)); ! end if; ! ! end Lock_Interrupt; ! ! ------------------------ ! -- Notify_Interrupt -- ! ------------------------ -- Umbrella handler for vectored hardware interrupts (as opposed to -- signals and exceptions). As opposed to the signal implementation, --- 619,630 ---- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is begin ! return False; end Is_Reserved; ! ---------------------- ! -- Notify_Interrupt -- ! ---------------------- -- Umbrella handler for vectored hardware interrupts (as opposed to -- signals and exceptions). As opposed to the signal implementation, *************** package body System.Interrupts is *** 858,872 **** end if; end Register_Interrupt_Handler; - --------------- - -- To_Signal -- - --------------- - - function To_Signal (S : Interrupt_ID) return IMNG.Interrupt_ID is - begin - return IMNG.Interrupt_ID (S - System.VxWorks.Num_HW_Interrupts); - end To_Signal; - ----------------------- -- Unblock_Interrupt -- ----------------------- --- 693,698 ---- *************** package body System.Interrupts is *** 907,934 **** Feature & " not implemented on VxWorks"); end Unimplemented; - ---------------------- - -- Unlock_Interrupt -- - ---------------------- - - procedure Unlock_Interrupt - (Self_ID : Task_ID; - Interrupt : Interrupt_ID) is - begin - if Task_Lock (Interrupt) then - pragma Assert - (not Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt))), - "Attempt to unlock per task lock of terminated server"); - - POP.Unlock (Server_ID (Interrupt)); - else - POP.Unlock (L'Access); - end if; - - Initialization.Undefer_Abort (Self_ID); - end Unlock_Interrupt; - ----------------------- -- Interrupt_Manager -- ----------------------- --- 733,738 ---- *************** package body System.Interrupts is *** 938,946 **** -- Local Variables -- --------------------- ! Intwait_Mask : aliased IMNG.Interrupt_Mask; ! Old_Mask : aliased IMNG.Interrupt_Mask; ! Self_ID : Task_ID := POP.Self; -------------------- -- Local Routines -- --- 742,748 ---- -- Local Variables -- --------------------- ! Self_Id : constant Task_ID := POP.Self; -------------------- -- Local Routines -- *************** package body System.Interrupts is *** 956,965 **** -- Otherwise, we have to interrupt Server_Task for status change -- through an abort signal. - -- The following two procedures are labelled Unprotected... in order to - -- indicate that Lock/Unlock_Interrupt operations are needed around - -- around calls to them. - procedure Unprotected_Exchange_Handler (Old_Handler : out Parameterless_Handler; New_Handler : Parameterless_Handler; --- 758,763 ---- *************** package body System.Interrupts is *** 977,1000 **** procedure Bind_Handler (Interrupt : Interrupt_ID) is begin ! if Interrupt < System.VxWorks.Num_HW_Interrupts then ! Install_Umbrella_Handler ! (HW_Interrupt (Interrupt), Notify_Interrupt'Access); ! ! else ! -- Mask this task for the given signal so that all tasks ! -- are masked for the signal and the actual delivery of the ! -- signal will be caught using "sigwait" by the ! -- corresponding Server_Task. ! ! IMOP.Thread_Block_Interrupt (To_Signal (Interrupt)); ! -- We have installed a handler or an entry before we called ! -- this procedure. If the handler task is waiting to be ! -- awakened, do it here. Otherwise, the signal will be ! -- discarded. ! ! POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); ! end if; end Bind_Handler; -------------------- --- 775,782 ---- procedure Bind_Handler (Interrupt : Interrupt_ID) is begin ! Install_Umbrella_Handler ! (HW_Interrupt (Interrupt), Notify_Interrupt'Access); end Bind_Handler; -------------------- *************** package body System.Interrupts is *** 1003,1046 **** procedure Unbind_Handler (Interrupt : Interrupt_ID) is S : STATUS; - Ret_Interrupt : IMNG.Interrupt_ID; - - use type IMNG.Interrupt_ID; use type STATUS; begin ! if Interrupt < System.VxWorks.Num_HW_Interrupts then ! ! -- Hardware interrupt ! ! Install_Default_Action (HW_Interrupt (Interrupt)); ! ! -- Flush server task off semaphore, allowing it to terminate ! ! S := semFlush (Semaphore_ID_Map (Interrupt)); ! pragma Assert (S = 0); ! ! else ! -- Currently, there is a handler or an entry attached and ! -- the corresponding Server_Task is waiting on "sigwait." ! -- We have to wake up the Server_Task and make it ! -- wait on a condition variable by sending an ! -- Abort_Task_Interrupt ! ! -- Make sure corresponding Server_Task is out of its own ! -- sigwait state. ! ! POP.Abort_Task (Server_ID (Interrupt)); ! Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access); ! pragma Assert (Ret_Interrupt = IMNG.Abort_Task_Interrupt); ! IMOP.Install_Default_Action (To_Signal (Interrupt)); ! -- Unmake the Interrupt for this task in order to allow default ! -- action again. ! IMOP.Thread_Unblock_Interrupt (To_Signal (Interrupt)); ! end if; end Unbind_Handler; -------------------------------- --- 785,801 ---- procedure Unbind_Handler (Interrupt : Interrupt_ID) is S : STATUS; use type STATUS; begin ! -- Hardware interrupt ! Install_Default_Action (HW_Interrupt (Interrupt)); ! -- Flush server task off semaphore, allowing it to terminate ! S := semFlush (Semaphore_ID_Map (Interrupt)); ! pragma Assert (S = 0); end Unbind_Handler; -------------------------------- *************** package body System.Interrupts is *** 1054,1064 **** Old_Handler : Parameterless_Handler; begin if User_Entry (Interrupt).T /= Null_Task then - -- If an interrupt entry is installed raise -- Program_Error. (propagate it to the caller). - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "An interrupt entry is already installed"); end if; --- 809,817 ---- *************** package body System.Interrupts is *** 1068,1078 **** -- status of the Current_Handler. if not Static and then User_Handler (Interrupt).Static then - -- Trying to detach a static Interrupt Handler. -- raise Program_Error. - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "Trying to detach a static Interrupt Handler"); end if; --- 821,829 ---- *************** package body System.Interrupts is *** 1087,1093 **** if Old_Handler /= null then Unbind_Handler (Interrupt); end if; - end Unprotected_Detach_Handler; ---------------------------------- --- 838,843 ---- *************** package body System.Interrupts is *** 1102,1114 **** Restoration : Boolean := False) is begin if User_Entry (Interrupt).T /= Null_Task then - -- If an interrupt entry is already installed, raise -- Program_Error. (propagate it to the caller). ! Unlock_Interrupt (Self_ID, Interrupt); ! Raise_Exception (Program_Error'Identity, ! "An interrupt is already installed"); end if; -- Note : A null handler with Static = True will --- 852,863 ---- Restoration : Boolean := False) is begin if User_Entry (Interrupt).T /= Null_Task then -- If an interrupt entry is already installed, raise -- Program_Error. (propagate it to the caller). ! Raise_Exception ! (Program_Error'Identity, ! "An interrupt is already installed"); end if; -- Note : A null handler with Static = True will *************** package body System.Interrupts is *** 1121,1135 **** if not Restoration and then not Static and then (User_Handler (Interrupt).Static ! -- Trying to overwrite a static Interrupt Handler with a ! -- dynamic Handler ! -- The new handler is not specified as an ! -- Interrupt Handler by a pragma. ! or else not Is_Registered (New_Handler)) then - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "Trying to overwrite a static Interrupt Handler with a " & --- 870,883 ---- if not Restoration and then not Static and then (User_Handler (Interrupt).Static ! -- Trying to overwrite a static Interrupt Handler with a ! -- dynamic Handler ! -- The new handler is not specified as an ! -- Interrupt Handler by a pragma. ! or else not Is_Registered (New_Handler)) then Raise_Exception (Program_Error'Identity, "Trying to overwrite a static Interrupt Handler with a " & *************** package body System.Interrupts is *** 1164,1209 **** Ada.Task_Identification.Is_Terminated (To_Ada (Server_ID (Interrupt)))) then ! -- When a new Server_Task is created, it should have its ! -- signal mask set to the All_Tasks_Mask. ! ! IMOP.Set_Interrupt_Mask ! (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); ! ! if Interrupt < System.VxWorks.Num_HW_Interrupts then ! ! -- Vectored hardware interrupt ! ! Interrupt_Access_Hold := ! new Interrupt_Server_Task ! (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); ! Server_ID (Interrupt) := ! To_System (Interrupt_Access_Hold.all'Identity); ! ! else ! -- Signal ! ! Signal_Access_Hold := new Signal_Server_Task (Interrupt); ! Server_ID (Interrupt) := ! To_System (Signal_Access_Hold.all'Identity); ! end if; ! ! IMOP.Set_Interrupt_Mask (Old_Mask'Access); end if; if (New_Handler = null) and then Old_Handler /= null then - -- Restore default handler Unbind_Handler (Interrupt); elsif Old_Handler = null then - -- Save default handler Bind_Handler (Interrupt); end if; - end Unprotected_Exchange_Handler; -- Start of processing for Interrupt_Manager --- 912,934 ---- Ada.Task_Identification.Is_Terminated (To_Ada (Server_ID (Interrupt)))) then ! Interrupt_Access_Hold := ! new Interrupt_Server_Task ! (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); ! Server_ID (Interrupt) := ! To_System (Interrupt_Access_Hold.all'Identity); end if; if (New_Handler = null) and then Old_Handler /= null then -- Restore default handler Unbind_Handler (Interrupt); elsif Old_Handler = null then -- Save default handler Bind_Handler (Interrupt); end if; end Unprotected_Exchange_Handler; -- Start of processing for Interrupt_Manager *************** package body System.Interrupts is *** 1214,1269 **** System.Tasking.Utilities.Make_Independent; - -- Environment task gets its own interrupt mask, saves it, - -- and then masks all signals except the Keep_Unmasked set. - - -- During rendezvous, the Interrupt_Manager receives the old - -- signal mask of the environment task, and sets its own - -- signal mask to that value. - - -- The environment task will call this entry of Interrupt_Manager - -- during elaboration of the body of this package. - - accept Initialize (Mask : IMNG.Interrupt_Mask) do - declare - The_Mask : aliased IMNG.Interrupt_Mask; - - begin - IMOP.Copy_Interrupt_Mask (The_Mask, Mask); - IMOP.Set_Interrupt_Mask (The_Mask'Access); - end; - end Initialize; - - -- Note: All tasks in RTS will have all reserved signals - -- being masked (except the Interrupt_Manager) and Keep_Unmasked - -- signals unmasked when created. - - -- Abort_Task_Interrupt is one of the signals unmasked - -- in all tasks. We mask the signal in this particular task - -- so that "sigwait" is can catch an explicit - -- Abort_Task_Interrupt from a Server_Task. - - -- This sigwaiting is needed to ensure that a Signal_Server_Task is - -- out of its own sigwait state. This extra synchronization is - -- necessary to prevent following scenarios: - - -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to a - -- Signal_Server_Task then changes its own signal mask (OS level). - -- If a signal (corresponding to the Signal_Server_Task) arrives - -- in the meantime, we have the Interrupt_Manager umnasked and - -- the Signal_Server_Task waiting on sigwait. - - -- 2) For unbinding a handler, we install a default action in the - -- Interrupt_Manager. POSIX.1c states that the result of using - -- "sigwait" and "sigaction" simultaneously on the same signal - -- is undefined. Therefore, we need to be informed from the - -- Signal_Server_Task that it is out of its sigwait stage. - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); - IMOP.Thread_Block_Interrupt (IMNG.Abort_Task_Interrupt); - loop -- A block is needed to absorb Program_Error exception --- 939,944 ---- *************** package body System.Interrupts is *** 1272,1413 **** begin select - accept Attach_Handler (New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; Static : Boolean; Restoration : Boolean := False) do - Lock_Interrupt (Self_ID, Interrupt); Unprotected_Exchange_Handler (Old_Handler, New_Handler, Interrupt, Static, Restoration); - Unlock_Interrupt (Self_ID, Interrupt); end Attach_Handler; ! or accept Exchange_Handler ! (Old_Handler : out Parameterless_Handler; ! New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean) ! do ! Lock_Interrupt (Self_ID, Interrupt); ! Unprotected_Exchange_Handler ! (Old_Handler, New_Handler, Interrupt, Static); ! Unlock_Interrupt (Self_ID, Interrupt); ! end Exchange_Handler; ! ! or accept Detach_Handler ! (Interrupt : Interrupt_ID; ! Static : Boolean) ! do ! Lock_Interrupt (Self_ID, Interrupt); ! Unprotected_Detach_Handler (Interrupt, Static); ! Unlock_Interrupt (Self_ID, Interrupt); ! end Detach_Handler; ! ! or accept Bind_Interrupt_To_Entry ! (T : Task_ID; ! E : Task_Entry_Index; ! Interrupt : Interrupt_ID) ! do ! Lock_Interrupt (Self_ID, Interrupt); ! ! -- If there is a binding already (either a procedure or an ! -- entry), raise Program_Error (propagate it to the caller). ! ! if User_Handler (Interrupt).H /= null ! or else User_Entry (Interrupt).T /= Null_Task ! then ! Unlock_Interrupt (Self_ID, Interrupt); ! Raise_Exception ! (Program_Error'Identity, ! "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 ! -- the binding can be cleaned. The call to unbinding must be ! -- make by the task before it terminates. ! T.Interrupt_Entry := True; ! -- Invoke a corresponding Server_Task if not yet created. ! -- Place Task_ID info in Server_ID array. ! if Server_ID (Interrupt) = Null_Task or else ! Ada.Task_Identification.Is_Terminated ! (To_Ada (Server_ID (Interrupt))) then ! -- When a new Server_Task is created, it should have its ! -- signal mask set to the All_Tasks_Mask. ! IMOP.Set_Interrupt_Mask ! (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); ! if Interrupt < System.VxWorks.Num_HW_Interrupts then Interrupt_Access_Hold := new Interrupt_Server_Task (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); Server_ID (Interrupt) := To_System (Interrupt_Access_Hold.all'Identity); - - else - Signal_Access_Hold := new Signal_Server_Task (Interrupt); - Server_ID (Interrupt) := - To_System (Signal_Access_Hold.all'Identity); end if; ! IMOP.Set_Interrupt_Mask (Old_Mask'Access); ! end if; ! ! Bind_Handler (Interrupt); ! Unlock_Interrupt (Self_ID, Interrupt); ! end Bind_Interrupt_To_Entry; ! ! or accept Detach_Interrupt_Entries (T : Task_ID) ! do ! for Int in Interrupt_ID'Range loop ! if not Is_Reserved (Int) then ! Lock_Interrupt (Self_ID, Int); ! ! if User_Entry (Int).T = T then ! User_Entry (Int) := Entry_Assoc' ! (T => Null_Task, E => Null_Task_Entry); ! Unbind_Handler (Int); end if; ! Unlock_Interrupt (Self_ID, Int); ! end if; ! end loop; ! ! -- Indicate in ATCB that no interrupt entries are attached. ! ! T.Interrupt_Entry := False; ! end Detach_Interrupt_Entries; end select; exception - -- If there is a Program_Error we just want to propagate it to -- the caller and do not want to stop this task. when Program_Error => null; ! when E : others => ! pragma Assert ! (Shutdown ("Interrupt_Manager---exception not expected" & ! ASCII.LF & ! Exception_Information (E))); null; end; end loop; - pragma Assert (Shutdown ("Interrupt_Manager---should not get here")); exception when Standard'Abort_Signal => -- Flush interrupt server semaphores, so they can terminate --- 947,1054 ---- begin 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); end Attach_Handler; ! 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; ! or ! accept Bind_Interrupt_To_Entry ! (T : Task_ID; ! E : Task_Entry_Index; ! Interrupt : Interrupt_ID) ! do ! -- If there is a binding already (either a procedure or an ! -- entry), raise Program_Error (propagate it to the caller). ! if User_Handler (Interrupt).H /= null ! or else User_Entry (Interrupt).T /= Null_Task ! then ! Raise_Exception ! (Program_Error'Identity, ! "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 ! -- the binding can be cleaned. The call to unbinding must be ! -- make by the task before it terminates. ! T.Interrupt_Entry := True; ! -- Invoke a corresponding Server_Task if not yet created. ! -- Place Task_ID info in Server_ID array. ! if Server_ID (Interrupt) = Null_Task ! or else ! Ada.Task_Identification.Is_Terminated ! (To_Ada (Server_ID (Interrupt))) ! then Interrupt_Access_Hold := new Interrupt_Server_Task (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); Server_ID (Interrupt) := To_System (Interrupt_Access_Hold.all'Identity); end if; ! Bind_Handler (Interrupt); ! end Bind_Interrupt_To_Entry; ! or ! accept Detach_Interrupt_Entries (T : Task_ID) do ! 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; + end loop; ! -- Indicate in ATCB that no interrupt entries are attached. + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; end select; exception -- If there is a Program_Error we just want to propagate it to -- the caller and do not want to stop this task. when Program_Error => null; ! when others => ! pragma Assert (False); null; end; end loop; exception when Standard'Abort_Signal => -- Flush interrupt server semaphores, so they can terminate *************** package body System.Interrupts is *** 1415,1563 **** raise; end Interrupt_Manager; - ------------------------ - -- Signal_Server_Task -- - ------------------------ - - task body Signal_Server_Task is - Intwait_Mask : aliased IMNG.Interrupt_Mask; - Ret_Interrupt : IMNG.Interrupt_ID; - Self_ID : Task_ID := Self; - Tmp_Handler : Parameterless_Handler; - Tmp_ID : Task_ID; - Tmp_Entry_Index : Task_Entry_Index; - - use type IMNG.Interrupt_ID; - - begin - -- By making this task independent of master, when the process - -- goes away, the Server_Task will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - - -- Install default action in system level. - - IMOP.Install_Default_Action (To_Signal (Interrupt)); - - -- Note: All tasks in RTS will have all reserved signals - -- masked (except the Interrupt_Manager) and Keep_Unmasked - -- unmasked when created. - - -- Abort_Task_Interrupt is one of the signals unmasked - -- in all tasks. We mask it in this particular task - -- so that "sigwait" can catch an explicit - -- Abort_Task_Interrupt from the Interrupt_Manager. - - -- There are two signals that this task catches through - -- "sigwait." One is the signal it is designated to catch - -- in order to execute an user handler or entry. The other is - -- Abort_Task_Interrupt. This signal is sent from the - -- Interrupt_Manager to inform of status changes (e.g: become Blocked, - -- or a handler or entry is to be detached). - - -- Prepare the mask to be used for sigwait. - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, To_Signal (Interrupt)); - - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); - - IMOP.Thread_Block_Interrupt (IMNG.Abort_Task_Interrupt); - - PIO.Set_Interrupt_ID (To_Signal (Interrupt), Self_ID); - - loop - System.Tasking.Initialization.Defer_Abort (Self_ID); - POP.Write_Lock (Self_ID); - - if User_Handler (Interrupt).H = null - and then User_Entry (Interrupt).T = Null_Task - then - - -- No signal binding. If a signal is received, - -- Interrupt_Manager will take the default action. - - Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; - POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); - Self_ID.Common.State := Runnable; - - else - -- A handler or an entry is installed. At this point all tasks - -- mask for the signal is masked. Catch it using - -- sigwait. - - -- This task may wake up from sigwait by receiving a signal - -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding - -- a procedure handler or an entry. Or it could be a wake up - -- from status change (Unblocked -> Blocked). If that is not - -- the case, we should execute the attached procedure or entry. - - POP.Unlock (Self_ID); - - Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access); - - if Ret_Interrupt = IMNG.Abort_Task_Interrupt then - -- Inform the Interrupt_Manager of wakeup from above sigwait. - - POP.Abort_Task (Interrupt_Manager_ID); - POP.Write_Lock (Self_ID); - - else - POP.Write_Lock (Self_ID); - - -- Even though we have received a signal, the status may - -- have changed before we got the Self_ID lock above. - -- Therefore we make sure a handler or an entry is still - -- bound and make appropriate call. - -- If there is no call to make we need to regenerate the - -- signal in order not to lose it. - - if User_Handler (Interrupt).H /= null then - - Tmp_Handler := User_Handler (Interrupt).H; - - -- RTS calls should not be made with self being locked. - - POP.Unlock (Self_ID); - - Tmp_Handler.all; - 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; - - -- RTS calls should not be made with self being locked. - - POP.Unlock (Self_ID); - - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - POP.Write_Lock (Self_ID); - else - -- This is a situation where this task woke up receiving a - -- signal and before it got the lock the signal was blocked. - -- We do not want to lose the signal so we regenerate it at - -- the process level. - - IMOP.Interrupt_Self_Process (Ret_Interrupt); - end if; - end if; - end if; - - POP.Unlock (Self_ID); - System.Tasking.Initialization.Undefer_Abort (Self_ID); - - -- Undefer abort here to allow a window for this task - -- to be aborted at the time of system shutdown. - end loop; - end Signal_Server_Task; - --------------------------- -- Interrupt_Server_Task -- --------------------------- --- 1056,1061 ---- *************** package body System.Interrupts is *** 1565,1571 **** -- Server task for vectored hardware interrupt handling task body Interrupt_Server_Task is ! Self_ID : Task_ID := Self; Tmp_Handler : Parameterless_Handler; Tmp_ID : Task_ID; Tmp_Entry_Index : Task_Entry_Index; --- 1063,1069 ---- -- Server task for vectored hardware interrupt handling task body Interrupt_Server_Task is ! Self_Id : constant Task_ID := Self; Tmp_Handler : Parameterless_Handler; Tmp_ID : Task_ID; Tmp_Entry_Index : Task_Entry_Index; *************** package body System.Interrupts is *** 1606,1612 **** -- Wait for the Interrupt_Manager to complete its work ! POP.Write_Lock (Self_ID); -- Delete the associated semaphore --- 1104,1110 ---- -- Wait for the Interrupt_Manager to complete its work ! POP.Write_Lock (Self_Id); -- Delete the associated semaphore *************** package body System.Interrupts is *** 1617,1625 **** -- Set status for the Interrupt_Manager Semaphore_ID_Map (Interrupt) := 0; - Task_Lock (Interrupt) := False; Server_ID (Interrupt) := Null_Task; ! POP.Unlock (Self_ID); exit; end if; --- 1115,1122 ---- -- Set status for the Interrupt_Manager Semaphore_ID_Map (Interrupt) := 0; Server_ID (Interrupt) := Null_Task; ! POP.Unlock (Self_Id); exit; end if; *************** package body System.Interrupts is *** 1627,1657 **** end Interrupt_Server_Task; begin - -- Elaboration code for package System.Interrupts - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - - -- Initialize the lock L. - - Initialization.Defer_Abort (Self); - POP.Initialize_Lock (L'Access, POP.PO_Level); - Initialization.Undefer_Abort (Self); - - -- During the elaboration of this package body we want the RTS to - -- inherit its signal mask from the Environment Task. - - -- The Environment Task should have gotten its mask from - -- the enclosing process during the RTS start up. (See - -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment - -- task to the Interrupt_Manager. - - -- Note : At this point we know that all tasks (including - -- RTS internal servers) are masked for non-reserved signals - -- (see s-taprop.adb). Only the Interrupt_Manager will have - -- masks set up differently, inheriting the original Environment - -- Task's mask. - - Interrupt_Manager.Initialize (IMOP.Environment_Mask); end System.Interrupts; --- 1124,1130 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5zintman.adb gcc-3.3/gcc/ada/5zintman.adb *** gcc-3.2.3/gcc/ada/5zintman.adb 2001-10-02 13:42:29.000000000 +0000 --- gcc-3.3/gcc/ada/5zintman.adb 2002-10-23 08:27:55.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** *** 52,93 **** -- may be used by the thread library. with Interfaces.C; - -- used for int and other types - - with System.Error_Reporting; - pragma Warnings (Off, System.Error_Reporting); - -- used for Shutdown with System.OS_Interface; -- used for various Constants, Signal and types - with Unchecked_Conversion; - package body System.Interrupt_Management is - use Interfaces.C; - use System.Error_Reporting; use System.OS_Interface; ! ! function To_Isr is new Unchecked_Conversion (Long_Integer, isr_address); type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; ! Exception_Interrupts : constant Interrupt_List := (SIGFPE, SIGILL, SIGSEGV, SIGBUS); -- Keep these variables global so that they are initialized only once. Exception_Action : aliased struct_sigaction; - Default_Action : aliased struct_sigaction; - - -- ????? Use these horrible imports here to solve elaboration order - -- problems. - - type Task_Id is access all Integer; - - Interrupt_ID_Map : array (Interrupt_ID) of Task_Id; - pragma Import (Ada, Interrupt_ID_Map, - "system__task_primitives__interrupt_operations__interrupt_id_map"); ---------------------- -- Notify_Exception -- --- 50,71 ---- -- may be used by the thread library. with Interfaces.C; with System.OS_Interface; -- used for various Constants, Signal and types package body System.Interrupt_Management is 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 -- *************** package body System.Interrupt_Management *** 99,111 **** procedure Notify_Exception (signo : Signal) is Mask : aliased sigset_t; ! Result : Interfaces.C.int; ! My_Id : pthread_t; 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, signo); Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null); --- 77,86 ---- 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); Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null); *************** package body System.Interrupt_Management *** 114,139 **** -- 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; - -- 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. - - -- How can SIGSEGV be split into constraint and storage errors? - -- What should SIGILL really raise ? Some implementations have - -- codes for different types of SIGILL and some raise Storage_Error. - -- What causes SIGBUS and should it be caught? - -- Peter Burwood - case signo is when SIGFPE => raise Constraint_Error; --- 89,99 ---- -- 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; *************** package body System.Interrupt_Management *** 144,206 **** when SIGBUS => raise Program_Error; when others => ! pragma Assert (Shutdown ("Unexpected signal")); ! null; end case; end Notify_Exception; - ------------------- - -- Notify_Signal -- - ------------------- - - -- VxWorks needs a special casing here. Each VxWorks task has a completely - -- separate signal handling, so the usual signal masking can't work. - -- This idea is to handle all the signals in all the tasks, and when - -- such a signal occurs, redirect it to the dedicated task (if any) or - -- reraise it. - - procedure Notify_Signal (signo : Signal); - - procedure Notify_Signal (signo : Signal) is - Mask : aliased sigset_t; - Result : Interfaces.C.int; - My_Id : pthread_t; - old_isr : isr_address; - - function Get_Thread_Id (T : Task_Id) return pthread_t; - pragma Import (Ada, Get_Thread_Id, - "system__task_primitives__operations__get_thread_id"); - - 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, signo); - Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null); - - -- 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; - - -- ??? Need a lock around this, in case the handler is detached - -- between the two following statements. - - if Interrupt_ID_Map (Interrupt_ID (signo)) /= null then - Result := - kill (Get_Thread_Id (Interrupt_ID_Map (Interrupt_ID (signo))), - Signal (signo)); - else - old_isr := c_signal (signo, To_Isr (SIG_DFL)); - Result := kill (My_Id, Signal (signo)); - end if; - end Notify_Signal; - --------------------------- -- Initialize_Interrupts -- --------------------------- --- 104,114 ---- when SIGBUS => raise Program_Error; when others => ! -- Unexpected signal ! raise Program_Error; end case; end Notify_Exception; --------------------------- -- Initialize_Interrupts -- --------------------------- *************** package body System.Interrupt_Management *** 209,228 **** -- to initialize signal handling in each task. procedure Initialize_Interrupts is old_act : aliased struct_sigaction; - Result : Interfaces.C.int; begin - for J in Interrupt_ID'First + 1 .. Interrupt_ID'Last loop - if J /= Abort_Task_Interrupt then - Result := sigaction (Signal (J), Default_Action'Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end if; - end loop; - for J in Exception_Interrupts'Range loop - Keep_Unmasked (Exception_Interrupts (J)) := True; Result := sigaction (Signal (Exception_Interrupts (J)), Exception_Action'Access, --- 117,127 ---- -- to initialize signal handling in each task. procedure Initialize_Interrupts is + Result : int; old_act : aliased struct_sigaction; begin for J in Exception_Interrupts'Range loop Result := sigaction (Signal (Exception_Interrupts (J)), Exception_Action'Access, *************** package body System.Interrupt_Management *** 233,295 **** begin declare ! mask : aliased sigset_t; ! default_mask : aliased sigset_t; ! Result : Interfaces.C.int; ! begin - -- The VxWorks POSIX threads library currently needs initialization. - -- We wish it could be in System.OS_Interface, but that would - -- cause an elaboration problem. - - pthread_init; - 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; ! Default_Action.sa_handler := Notify_Signal'Address; ! ! Exception_Action.sa_flags := SA_SIGINFO + SA_ONSTACK; ! Default_Action.sa_flags := SA_SIGINFO + SA_ONSTACK; ! -- Send us extra signal information (SA_SIGINFO) on the ! -- stack (SA_ONSTACK). ! -- There is no SA_NODEFER in VxWorks. The signal mask is ! -- restored after a longjmp so the SA_NODEFER option is ! -- not needed. - Dan Eischen ! Result := sigemptyset (mask'Access); pragma Assert (Result = 0); - Result := sigemptyset (default_mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_ID'First + 1 .. Interrupt_ID'Last loop - Result := sigaddset (default_mask'Access, Signal (J)); - pragma Assert (Result = 0); - end loop; for J in Exception_Interrupts'Range loop Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J))); pragma Assert (Result = 0); - Result := - sigdelset (default_mask'Access, Signal (Exception_Interrupts (J))); - pragma Assert (Result = 0); end loop; Exception_Action.sa_mask := mask; - Default_Action.sa_mask := default_mask; - - -- Initialize_Interrupts is called for each task in Enter_Task - - Keep_Unmasked (Abort_Task_Interrupt) := True; - - Reserve := Reserve or Keep_Unmasked or Keep_Masked; - - 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; --- 132,154 ---- begin 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5zosinte.adb gcc-3.3/gcc/ada/5zosinte.adb *** gcc-3.2.3/gcc/ada/5zosinte.adb 2002-05-04 03:27:18.000000000 +0000 --- gcc-3.3/gcc/ada/5zosinte.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1997-2001 Free Software Foundation -- -- -- -- GNARL is 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) 1997-2002 Free Software Foundation -- -- -- -- GNARL is 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); *** 42,212 **** -- 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; - - with System.VxWorks; - -- used for Wind_TCB_Ptr - - with Unchecked_Conversion; - package body System.OS_Interface is ! use System.VxWorks; ! ! -- Option flags for taskSpawn ! ! VX_UNBREAKABLE : constant := 16#0002#; ! VX_FP_TASK : constant := 16#0008#; ! VX_FP_PRIVATE_ENV : constant := 16#0080#; ! VX_NO_STACK_FILL : constant := 16#0100#; ! ! function taskSpawn ! (name : System.Address; -- Pointer to task name ! priority : int; ! options : int; ! stacksize : size_t; ! start_routine : Thread_Body; ! arg1 : System.Address; ! arg2 : int := 0; ! arg3 : int := 0; ! arg4 : int := 0; ! arg5 : int := 0; ! arg6 : int := 0; ! arg7 : int := 0; ! arg8 : int := 0; ! arg9 : int := 0; ! arg10 : int := 0) return pthread_t; ! pragma Import (C, taskSpawn, "taskSpawn"); ! ! procedure taskDelete (tid : pthread_t); ! pragma Import (C, taskDelete, "taskDelete"); ! ! -- These are the POSIX scheduling priorities. These are enabled ! -- when the global variable posixPriorityNumbering is 1. ! ! POSIX_SCHED_FIFO_LOW_PRI : constant := 0; ! POSIX_SCHED_FIFO_HIGH_PRI : constant := 255; ! POSIX_SCHED_RR_LOW_PRI : constant := 0; ! POSIX_SCHED_RR_HIGH_PRI : constant := 255; ! ! -- These are the VxWorks native (default) scheduling priorities. ! -- These are used when the global variable posixPriorityNumbering ! -- is 0. ! ! SCHED_FIFO_LOW_PRI : constant := 255; ! SCHED_FIFO_HIGH_PRI : constant := 0; ! SCHED_RR_LOW_PRI : constant := 255; ! SCHED_RR_HIGH_PRI : constant := 0; ! ! -- Global variable to enable POSIX priority numbering. ! -- By default, it is 0 and VxWorks native priority numbering ! -- is used. ! ! posixPriorityNumbering : int; ! pragma Import (C, posixPriorityNumbering, "posixPriorityNumbering"); ! ! -- VxWorks will let you set round-robin scheduling globally ! -- for all tasks, but not for individual tasks. Attempting ! -- to set the scheduling policy for a specific task (using ! -- sched_setscheduler) to something other than what the system ! -- is currently using will fail. If you wish to change the ! -- scheduling policy, then use the following function to set ! -- it globally for all tasks. When ticks is 0, time slicing ! -- (round-robin scheduling) is disabled. ! ! function kernelTimeSlice (ticks : int) return int; ! pragma Import (C, kernelTimeSlice, "kernelTimeSlice"); ! ! function taskPriorityGet ! (tid : pthread_t; ! pPriority : access int) ! return int; ! pragma Import (C, taskPriorityGet, "taskPriorityGet"); ! ! function taskPrioritySet ! (tid : pthread_t; ! newPriority : int) ! return int; ! pragma Import (C, taskPrioritySet, "taskPrioritySet"); ! ! function To_Wind_TCB_Ptr is ! new Unchecked_Conversion (pthread_t, Wind_TCB_Ptr); ! ! ! -- Error codes (errno). The lower level 16 bits are the ! -- error code, with the upper 16 bits representing the ! -- module number in which the error occurred. By convention, ! -- the module number is 0 for UNIX errors. VxWorks reserves ! -- module numbers 1-500, with the remaining module numbers ! -- being available for user applications. ! ! M_objLib : constant := 61 * 2**16; ! -- semTake() failure with ticks = NO_WAIT ! S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; ! -- semTake() timeout with ticks > NO_WAIT ! S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; ! ! -- We use two different kinds of VxWorks semaphores: mutex ! -- and binary semaphores. A null (0) ID is returned when ! -- a semaphore cannot be created. Binary semaphores and common ! -- operations are declared in the spec of this package, ! -- as they are used to implement hardware interrupt handling ! ! function semMCreate ! (options : int) return SEM_ID; ! pragma Import (C, semMCreate, "semMCreate"); ! ! ! function taskLock return int; ! pragma Import (C, taskLock, "taskLock"); ! ! function taskUnlock return int; ! pragma Import (C, taskUnlock, "taskUnlock"); ! ! ------------------------------------------------------- ! -- Convenience routines to convert between VxWorks -- ! -- priority and POSIX priority. -- ! ------------------------------------------------------- ! ! function To_Vxworks_Priority (Priority : in int) return int; ! pragma Inline (To_Vxworks_Priority); ! ! function To_Posix_Priority (Priority : in int) return int; ! pragma Inline (To_Posix_Priority); ! ! function To_Vxworks_Priority (Priority : in int) return int is ! begin ! return SCHED_FIFO_LOW_PRI - Priority; ! end To_Vxworks_Priority; ! ! function To_Posix_Priority (Priority : in int) return int is ! begin ! return SCHED_FIFO_LOW_PRI - Priority; ! end To_Posix_Priority; ! ! ---------------------------------------- ! -- Implementation of POSIX routines -- ! ---------------------------------------- ! ! ----------------------------------------- ! -- Nonstandard Thread Initialization -- ! ----------------------------------------- ! procedure pthread_init is ! begin ! Keys_Created := 0; ! Time_Slice := -1; ! end pthread_init; ! --------------------------- ! -- POSIX.1c Section 3 -- ! --------------------------- function sigwait (set : access sigset_t; sig : access Signal) return int is ! Result : Interfaces.C.int; function sigwaitinfo (set : access sigset_t; sigvalue : System.Address) return int; --- 41,62 ---- -- 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 ! use type Interfaces.C.int; ! Low_Priority : constant := 255; ! -- VxWorks native (default) lowest scheduling priority. ! ------------- ! -- sigwait -- ! ------------- function sigwait (set : access sigset_t; sig : access Signal) return int is ! Result : int; function sigwaitinfo (set : access sigset_t; sigvalue : System.Address) return int; *************** package body System.OS_Interface is *** 224,755 **** end if; end sigwait; - ---------------------------- - -- POSIX.1c Section 11 -- - ---------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int is - begin - -- Let's take advantage of VxWorks priority inversion - -- protection. - -- - -- ??? - Do we want to also specify SEM_DELETE_SAFE??? - - attr.Flags := int (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); - - -- Initialize the ceiling priority to the maximim priority. - -- We will use POSIX priorities since these routines are - -- emulating POSIX routines. - - attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; - attr.Protocol := PTHREAD_PRIO_INHERIT; - return 0; - end pthread_mutexattr_init; - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int is - begin - attr.Flags := 0; - attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; - attr.Protocol := PTHREAD_PRIO_INHERIT; - return 0; - end pthread_mutexattr_destroy; - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int - is - Result : int := 0; - - begin - -- A mutex should initially be created full and the task - -- protected from deletion while holding the semaphore. - - mutex.Mutex := semMCreate (attr.Flags); - mutex.Prio_Ceiling := attr.Prio_Ceiling; - mutex.Protocol := attr.Protocol; - - if mutex.Mutex = 0 then - Result := errno; - end if; - - return Result; - end pthread_mutex_init; - - function pthread_mutex_destroy - (mutex : access pthread_mutex_t) return int - is - Result : STATUS; - begin - Result := semDelete (mutex.Mutex); - - if Result /= 0 then - Result := errno; - end if; - - mutex.Mutex := 0; -- Ensure the mutex is properly cleaned. - mutex.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; - mutex.Protocol := PTHREAD_PRIO_INHERIT; - return Result; - end pthread_mutex_destroy; - - function pthread_mutex_lock - (mutex : access pthread_mutex_t) return int - is - Result : int; - WTCB_Ptr : Wind_TCB_Ptr; - begin - WTCB_Ptr := To_Wind_TCB_Ptr (taskIdSelf); - - if WTCB_Ptr = null then - return errno; - end if; - - -- Check the current inherited priority in the WIND_TCB - -- against the mutex ceiling priority and return EINVAL - -- upon a ceiling violation. - -- - -- We always convert the VxWorks priority to POSIX priority - -- in case the current priority ordering has changed (see - -- posixPriorityNumbering). The mutex ceiling priority is - -- maintained as POSIX compatible. - - if mutex.Protocol = PTHREAD_PRIO_PROTECT and then - To_Posix_Priority (WTCB_Ptr.Priority) > mutex.Prio_Ceiling - then - return EINVAL; - end if; - - Result := semTake (mutex.Mutex, WAIT_FOREVER); - - if Result /= 0 then - Result := errno; - end if; - - return Result; - end pthread_mutex_lock; - - function pthread_mutex_unlock - (mutex : access pthread_mutex_t) return int - is - Result : int; - begin - Result := semGive (mutex.Mutex); - - if Result /= 0 then - Result := errno; - end if; - - return Result; - end pthread_mutex_unlock; - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int is - begin - attr.Flags := SEM_Q_PRIORITY; - return 0; - end pthread_condattr_init; - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int is - begin - attr.Flags := 0; - return 0; - end pthread_condattr_destroy; - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int - is - Result : int := 0; - - begin - -- Condition variables should be initially created - -- empty. - - cond.Sem := semBCreate (attr.Flags, SEM_EMPTY); - cond.Waiting := 0; - - if cond.Sem = 0 then - Result := errno; - end if; - - return Result; - end pthread_cond_init; - - function pthread_cond_destroy (cond : access pthread_cond_t) return int is - Result : int; - - begin - Result := semDelete (cond.Sem); - - if Result /= 0 then - Result := errno; - end if; - - return Result; - end pthread_cond_destroy; - - function pthread_cond_signal - (cond : access pthread_cond_t) return int - is - Result : int := 0; - Status : int; - - begin - -- Disable task scheduling. - - Status := 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 cond.Waiting > 0 then - Result := semGive (cond.Sem); - - -- One less thread waiting on the CV. - - cond.Waiting := cond.Waiting - 1; - - if Result /= 0 then - Result := errno; - end if; - end if; - - -- Reenable task scheduling. - - Status := taskUnlock; - - return Result; - end pthread_cond_signal; - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int - is - Result : int; - Status : int; - begin - -- Disable task scheduling. - - Status := taskLock; - - -- Release the mutex as required by POSIX. - - Result := semGive (mutex.Mutex); - - -- Indicate that there is another thread waiting on the CV. - - cond.Waiting := cond.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 (cond.Sem, WAIT_FOREVER); - - if Result /= 0 then - cond.Waiting := cond.Waiting - 1; - Result := EINVAL; - end if; - - -- Take the mutex as required by POSIX. - - Status := semTake (mutex.Mutex, WAIT_FOREVER); - - if Status /= 0 then - Result := EINVAL; - end if; - - -- Reenable task scheduling. - - Status := taskUnlock; - - return Result; - end pthread_cond_wait; - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int - is - Result : int; - Status : int; - Ticks : int; - TS : aliased timespec; - begin - Status := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); - - -- Calculate the number of clock ticks for the timeout. - - Ticks := To_Clock_Ticks (To_Duration (abstime.all) - To_Duration (TS)); - - if Ticks <= 0 then - -- It is not worth the time to try to perform a semTake, - -- because we know it will always fail. A semTake with - -- ticks = 0 (NO_WAIT) will not block and therefore not - -- allow another task to give the semaphore. And if we've - -- designed pthread_cond_signal correctly, the semaphore - -- should never be left in a full state. - -- - -- Make sure we give up the CPU. - - Status := taskDelay (0); - return ETIMEDOUT; - end if; - - -- Disable task scheduling. - - Status := taskLock; - - -- Release the mutex as required by POSIX. - - Result := semGive (mutex.Mutex); - - -- Indicate that there is another thread waiting on the CV. - - cond.Waiting := cond.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 (cond.Sem, Ticks); - - if Result /= 0 then - if errno = S_objLib_OBJ_TIMEOUT then - Result := ETIMEDOUT; - else - Result := EINVAL; - end if; - cond.Waiting := cond.Waiting - 1; - end if; - - -- Take the mutex as required by POSIX. - - Status := semTake (mutex.Mutex, WAIT_FOREVER); - - if Status /= 0 then - Result := EINVAL; - end if; - - -- Reenable task scheduling. - - Status := taskUnlock; - - return Result; - end pthread_cond_timedwait; - - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int is - begin - if protocol < PTHREAD_PRIO_NONE - or protocol > PTHREAD_PRIO_PROTECT - then - return EINVAL; - end if; - - attr.Protocol := protocol; - return 0; - end pthread_mutexattr_setprotocol; - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int is - begin - -- Our interface to the rest of the world is meant - -- to be POSIX compliant; keep the priority in POSIX - -- format. - - attr.Prio_Ceiling := prioceiling; - return 0; - end pthread_mutexattr_setprioceiling; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int - is - Result : int; - begin - -- Convert the POSIX priority to VxWorks native - -- priority. - - Result := taskPrioritySet (thread, - To_Vxworks_Priority (param.sched_priority)); - return 0; - end pthread_setschedparam; - - function sched_yield return int is - begin - return taskDelay (0); - end sched_yield; - - function pthread_sched_rr_set_interval (usecs : int) return int is - Result : int := 0; - D_Slice : Duration; - begin - -- Check to see if round-robin scheduling (time slicing) - -- is enabled. If the time slice is the default value (-1) - -- or any negative number, we will leave the kernel time - -- slice unchanged. If the time slice is 0, we disable - -- kernel time slicing by setting it to 0. Otherwise, we - -- set the kernel time slice to the specified value converted - -- to clock ticks. - - Time_Slice := usecs; - - if Time_Slice > 0 then - D_Slice := Duration (Time_Slice) / Duration (1_000_000.0); - Result := kernelTimeSlice (To_Clock_Ticks (D_Slice)); - - else - if Time_Slice = 0 then - Result := kernelTimeSlice (0); - end if; - end if; - - return Result; - end pthread_sched_rr_set_interval; - - function pthread_attr_init (attr : access pthread_attr_t) return int is - begin - attr.Stacksize := 100000; -- What else can I do? - attr.Detachstate := PTHREAD_CREATE_DETACHED; - attr.Priority := POSIX_SCHED_FIFO_LOW_PRI; - attr.Taskname := System.Null_Address; - return 0; - end pthread_attr_init; - - function pthread_attr_destroy (attr : access pthread_attr_t) return int is - begin - attr.Stacksize := 0; - attr.Detachstate := 0; - attr.Priority := POSIX_SCHED_FIFO_LOW_PRI; - attr.Taskname := System.Null_Address; - return 0; - end pthread_attr_destroy; - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int is - begin - attr.Detachstate := detachstate; - return 0; - end pthread_attr_setdetachstate; - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int is - begin - attr.Stacksize := stacksize; - return 0; - end pthread_attr_setstacksize; - - -- In VxWorks tasks, we can set the task name. This - -- makes it really convenient for debugging. - - function pthread_attr_setname_np - (attr : access pthread_attr_t; - name : System.Address) return int is - begin - attr.Taskname := name; - return 0; - end pthread_attr_setname_np; - - function pthread_create - (thread : access pthread_t; - attr : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int is - begin - thread.all := taskSpawn (attr.Taskname, - To_Vxworks_Priority (attr.Priority), VX_FP_TASK, attr.Stacksize, - start_routine, arg); - - if thread.all = -1 then - return -1; - else - return 0; - end if; - end pthread_create; - - function pthread_detach (thread : pthread_t) return int is - begin - return 0; - end pthread_detach; - - procedure pthread_exit (status : System.Address) is - begin - taskDelete (0); - end pthread_exit; - - function pthread_self return pthread_t is - begin - return taskIdSelf; - end pthread_self; - - function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int is - begin - if t1 = t2 then - return 1; - else - return 0; - end if; - end pthread_equal; - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int - is - Result : int; - begin - if Integer (key) not in Key_Storage'Range then - return EINVAL; - end if; - - Key_Storage (Integer (key)) := value; - Result := taskVarAdd (taskIdSelf, Key_Storage (Integer (key))'Access); - - -- We should be able to directly set the key with the following: - -- Key_Storage (key) := value; - -- but we'll be safe and use taskVarSet. - -- ??? Come back and revisit this. - - Result := taskVarSet (taskIdSelf, - Key_Storage (Integer (key))'Access, value); - return Result; - end pthread_setspecific; - - function pthread_getspecific (key : pthread_key_t) return System.Address is - begin - return Key_Storage (Integer (key)); - end pthread_getspecific; - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int is - begin - Keys_Created := Keys_Created + 1; - - if Keys_Created not in Key_Storage'Range then - return ENOMEM; - end if; - - key.all := pthread_key_t (Keys_Created); - return 0; - end pthread_key_create; - ----------------- -- To_Duration -- ----------------- --- 74,79 ---- *************** package body System.OS_Interface is *** 776,796 **** 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; -------------------- -- To_Clock_Ticks -- -------------------- -- ??? - For now, we'll always get the system clock rate -- since it is allowed to be changed during run-time in ! -- VxWorks. A better method would be to provide an operation -- to set it that so we can always know its value. -- -- Another thing we should probably allow for is a resultant ! -- tick count greater than int'Last. This should probably -- be a procedure with two output parameters, one in the -- range 0 .. int'Last, and another representing the overflow -- count. --- 100,130 ---- 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; + ------------------------- + -- To_VxWorks_Priority -- + ------------------------- + + function To_VxWorks_Priority (Priority : in int) return int is + begin + return Low_Priority - Priority; + end To_VxWorks_Priority; + -------------------- -- To_Clock_Ticks -- -------------------- -- ??? - For now, we'll always get the system clock rate -- since it is allowed to be changed during run-time in ! -- VxWorks. A better method would be to provide an operation -- to set it that so we can always know its value. -- -- Another thing we should probably allow for is a resultant ! -- tick count greater than int'Last. This should probably -- be a procedure with two output parameters, one in the -- range 0 .. int'Last, and another representing the overflow -- count. *************** package body System.OS_Interface is *** 799,805 **** --- 133,143 ---- 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_Interface is *** 808,817 **** 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); --- 146,152 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5zosinte.ads gcc-3.3/gcc/ada/5zosinte.ads *** gcc-3.2.3/gcc/ada/5zosinte.ads 2002-05-04 03:27:18.000000000 +0000 --- gcc-3.3/gcc/ada/5zosinte.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** *** 49,67 **** with Interfaces.C; with System.VxWorks; package System.OS_Interface is pragma Preelaborate; ! subtype int is Interfaces.C.int; ! subtype short is Interfaces.C.short; ! subtype long is Interfaces.C.long; ! subtype unsigned is Interfaces.C.unsigned; ! subtype unsigned_short is Interfaces.C.unsigned_short; ! subtype unsigned_long is Interfaces.C.unsigned_long; ! subtype unsigned_char is Interfaces.C.unsigned_char; ! subtype plain_char is Interfaces.C.plain_char; ! subtype size_t is Interfaces.C.size_t; ! subtype char is Interfaces.C.char; ----------- -- Errno -- --- 48,62 ---- with Interfaces.C; with System.VxWorks; + package System.OS_Interface is pragma Preelaborate; ! subtype int is Interfaces.C.int; ! subtype short is Short_Integer; ! type long is new Long_Integer; ! type unsigned_long is mod 2 ** long'Size; ! type size_t is mod 2 ** Standard'Address_Size; ----------- -- Errno -- *************** package System.OS_Interface is *** 82,95 **** -- Signals and Interrupts -- ---------------------------- - -- In order to support both signal and hardware interrupt handling, - -- the ranges of "interrupt IDs" for the vectored hardware interrupts - -- and the signals are catenated. In other words, the external IDs - -- used to designate signals are relocated beyond the range of the - -- vectored interrupts. The IDs given in Ada.Interrupts.Names should - -- be used to designate signals; vectored interrupts are designated - -- by their interrupt number. - NSIG : constant := 32; -- Number of signals on the target OS type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); --- 77,82 ---- *************** package System.OS_Interface is *** 97,103 **** Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1; type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; ! Max_Interrupt : constant := Max_HW_Interrupt + NSIG; SIGILL : constant := 4; -- illegal instruction (not reset) SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future --- 84,90 ---- Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1; type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; ! Max_Interrupt : constant := Max_HW_Interrupt; SIGILL : constant := 4; -- illegal instruction (not reset) SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future *************** package System.OS_Interface is *** 115,124 **** SIG_SETMASK : constant := 3; -- The sa_flags in struct sigaction. ! SA_SIGINFO : constant := 16#0002#; ! SA_ONSTACK : constant := 16#0004#; - -- ANSI args and returns from signal(). SIG_DFL : constant := 0; SIG_IGN : constant := 1; --- 102,110 ---- SIG_SETMASK : constant := 3; -- The sa_flags in struct sigaction. ! SA_SIGINFO : constant := 16#0002#; ! SA_ONSTACK : constant := 16#0004#; SIG_DFL : constant := 0; SIG_IGN : constant := 1; *************** package System.OS_Interface is *** 169,174 **** --- 155,171 ---- oset : sigset_t_ptr) return int; pragma Import (C, pthread_sigmask, "sigprocmask"); + type t_id is new long; + subtype Thread_Id is t_id; + + function kill (pid : t_id; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + -- VxWorks doesn't have getpid; taskIdSelf is the equivalent + -- routine. + function getpid return t_id; + pragma Import (C, getpid, "taskIdSelf"); + ---------- -- Time -- ---------- *************** package System.OS_Interface is *** 198,458 **** (clock_id : clockid_t; tp : access timespec) return int; pragma Import (C, clock_gettime, "clock_gettime"); ! ------------------------- ! -- Priority Scheduling -- ! ------------------------- ! ! -- Scheduling policies. ! SCHED_FIFO : constant := 1; ! SCHED_RR : constant := 2; ! SCHED_OTHER : constant := 4; ! ! ------------- ! -- Threads -- ! ------------- ! ! type Thread_Body is access ! function (arg : System.Address) return System.Address; ! ! type pthread_t is private; ! subtype Thread_Id is pthread_t; ! ! null_pthread : constant pthread_t; ! ! type pthread_mutex_t is limited private; ! type pthread_cond_t is limited private; ! type pthread_attr_t is limited private; ! type pthread_mutexattr_t is limited private; ! type pthread_condattr_t is limited private; ! type pthread_key_t is private; ! PTHREAD_CREATE_DETACHED : constant := 0; ! PTHREAD_CREATE_JOINABLE : constant := 1; ! function kill (pid : pthread_t; sig : Signal) return int; ! pragma Import (C, kill, "kill"); ! -- VxWorks doesn't have getpid; taskIdSelf is the equivalent ! -- routine. ! function getpid return pthread_t; ! pragma Import (C, getpid, "taskIdSelf"); ! --------------------------------- ! -- Nonstandard Thread Routines -- ! --------------------------------- ! procedure pthread_init; ! pragma Inline (pthread_init); ! -- Vxworks requires this for the moment. ! function taskIdSelf return pthread_t; pragma Import (C, taskIdSelf, "taskIdSelf"); ! function taskSuspend (tid : pthread_t) return int; pragma Import (C, taskSuspend, "taskSuspend"); ! function taskResume (tid : pthread_t) return int; pragma Import (C, taskResume, "taskResume"); ! function taskIsSuspended (tid : pthread_t) return int; pragma Import (C, taskIsSuspended, "taskIsSuspended"); function taskVarAdd ! (tid : pthread_t; ! pVar : access System.Address) return int; pragma Import (C, taskVarAdd, "taskVarAdd"); function taskVarDelete ! (tid : pthread_t; ! pVar : access System.Address) return int; pragma Import (C, taskVarDelete, "taskVarDelete"); function taskVarSet ! (tid : pthread_t; pVar : access System.Address; value : System.Address) return int; pragma Import (C, taskVarSet, "taskVarSet"); function taskVarGet ! (tid : pthread_t; ! pVar : access System.Address) return int; pragma Import (C, taskVarGet, "taskVarGet"); - function taskInfoGet - (tid : pthread_t; - pTaskDesc : access System.VxWorks.TASK_DESC) return int; - pragma Import (C, taskInfoGet, "taskInfoGet"); - function taskDelay (ticks : int) return int; pragma Import (C, taskDelay, "taskDelay"); function sysClkRateGet return int; pragma Import (C, sysClkRateGet, "sysClkRateGet"); ! -------------------------- ! -- POSIX.1c Section 11 -- ! -------------------------- ! ! function pthread_mutexattr_init ! (attr : access pthread_mutexattr_t) return int; ! pragma Inline (pthread_mutexattr_init); ! ! function pthread_mutexattr_destroy ! (attr : access pthread_mutexattr_t) return int; ! pragma Inline (pthread_mutexattr_destroy); ! ! function pthread_mutex_init ! (mutex : access pthread_mutex_t; ! attr : access pthread_mutexattr_t) return int; ! pragma Inline (pthread_mutex_init); ! ! function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; ! pragma Inline (pthread_mutex_destroy); ! ! function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; ! pragma Inline (pthread_mutex_lock); ! ! function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; ! pragma Inline (pthread_mutex_unlock); ! ! function pthread_condattr_init ! (attr : access pthread_condattr_t) return int; ! pragma Inline (pthread_condattr_init); ! ! function pthread_condattr_destroy ! (attr : access pthread_condattr_t) return int; ! pragma Inline (pthread_condattr_destroy); ! ! function pthread_cond_init ! (cond : access pthread_cond_t; ! attr : access pthread_condattr_t) return int; ! pragma Inline (pthread_cond_init); ! ! function pthread_cond_destroy (cond : access pthread_cond_t) return int; ! pragma Inline (pthread_cond_destroy); ! ! function pthread_cond_signal (cond : access pthread_cond_t) return int; ! pragma Inline (pthread_cond_signal); ! ! function pthread_cond_wait ! (cond : access pthread_cond_t; ! mutex : access pthread_mutex_t) return int; ! pragma Inline (pthread_cond_wait); ! ! function pthread_cond_timedwait ! (cond : access pthread_cond_t; ! mutex : access pthread_mutex_t; ! abstime : access timespec) return int; ! pragma Inline (pthread_cond_timedwait); ! ! -------------------------- ! -- 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 Inline (pthread_mutexattr_setprotocol); ! ! function pthread_mutexattr_setprioceiling ! (attr : access pthread_mutexattr_t; ! prioceiling : int) return int; ! pragma Inline (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 Inline (pthread_setschedparam); ! ! function sched_yield return int; ! pragma Inline (sched_yield); ! ! function pthread_sched_rr_set_interval (usecs : int) return int; ! pragma Inline (pthread_sched_rr_set_interval); ! ! --------------------------- ! -- P1003.1c - Section 16 -- ! --------------------------- ! ! function pthread_attr_init (attr : access pthread_attr_t) return int; ! pragma Inline (pthread_attr_init); ! ! function pthread_attr_destroy (attr : access pthread_attr_t) return int; ! pragma Inline (pthread_attr_destroy); ! ! function pthread_attr_setdetachstate ! (attr : access pthread_attr_t; ! detachstate : int) return int; ! pragma Inline (pthread_attr_setdetachstate); ! ! function pthread_attr_setstacksize ! (attr : access pthread_attr_t; ! stacksize : size_t) return int; ! pragma Inline (pthread_attr_setstacksize); ! ! function pthread_attr_setname_np ! (attr : access pthread_attr_t; ! name : System.Address) return int; ! -- In VxWorks tasks, we have a non-portable routine to set the ! -- task name. This makes it really convenient for debugging. ! pragma Inline (pthread_attr_setname_np); ! ! function pthread_create ! (thread : access pthread_t; ! attr : access pthread_attr_t; ! start_routine : Thread_Body; ! arg : System.Address) return int; ! pragma Inline (pthread_create); ! ! function pthread_detach (thread : pthread_t) return int; ! pragma Inline (pthread_detach); ! ! procedure pthread_exit (status : System.Address); ! pragma Inline (pthread_exit); ! ! function pthread_self return pthread_t; ! pragma Inline (pthread_self); ! ! function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int; ! pragma Inline (pthread_equal); ! -- be careful not to use "=" on thread_t! ! ! -------------------------- ! -- POSIX.1c Section 17 -- ! -------------------------- ! function pthread_setspecific ! (key : pthread_key_t; ! value : System.Address) return int; ! pragma Inline (pthread_setspecific); ! function pthread_getspecific (key : pthread_key_t) return System.Address; ! pragma Inline (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 Inline (pthread_key_create); ! -- VxWorks binary semaphores. These are exported for use by the ! -- implementation of hardware interrupt handling. subtype STATUS is int; -- Equivalent of the C type STATUS OK : constant STATUS := 0; ! ERROR : constant STATUS := Interfaces.C."-" (1); -- Semaphore creation flags. --- 195,298 ---- (clock_id : clockid_t; tp : access timespec) return int; pragma Import (C, clock_gettime, "clock_gettime"); ! type ULONG is new unsigned_long; ! procedure tickSet (ticks : ULONG); ! pragma Import (C, tickSet, "tickSet"); ! function tickGet return ULONG; ! pragma Import (C, tickGet, "tickGet"); ! ----------------------------------------------------- ! -- Convenience routine to convert between VxWorks -- ! -- priority and Ada priority. -- ! ----------------------------------------------------- ! function To_VxWorks_Priority (Priority : in int) return int; ! pragma Inline (To_VxWorks_Priority); ! -------------------------- ! -- VxWorks specific API -- ! -------------------------- ! function taskIdSelf return t_id; pragma Import (C, taskIdSelf, "taskIdSelf"); ! function taskSuspend (tid : t_id) return int; pragma Import (C, taskSuspend, "taskSuspend"); ! function taskResume (tid : t_id) return int; pragma Import (C, taskResume, "taskResume"); ! function taskIsSuspended (tid : t_id) return int; pragma Import (C, taskIsSuspended, "taskIsSuspended"); function taskVarAdd ! (tid : t_id; pVar : System.Address) return int; pragma Import (C, taskVarAdd, "taskVarAdd"); function taskVarDelete ! (tid : t_id; pVar : access System.Address) return int; pragma Import (C, taskVarDelete, "taskVarDelete"); function taskVarSet ! (tid : t_id; pVar : access System.Address; value : System.Address) return int; pragma Import (C, taskVarSet, "taskVarSet"); function taskVarGet ! (tid : t_id; ! pVar : access System.Address) return int; pragma Import (C, taskVarGet, "taskVarGet"); function taskDelay (ticks : int) return int; + procedure taskDelay (ticks : int); pragma Import (C, taskDelay, "taskDelay"); function sysClkRateGet return int; pragma Import (C, sysClkRateGet, "sysClkRateGet"); ! -- Option flags for taskSpawn ! VX_UNBREAKABLE : constant := 16#0002#; ! VX_FP_TASK : constant := 16#0008#; ! VX_FP_PRIVATE_ENV : constant := 16#0080#; ! VX_NO_STACK_FILL : constant := 16#0100#; ! function taskSpawn ! (name : System.Address; -- Pointer to task name ! priority : int; ! options : int; ! stacksize : size_t; ! start_routine : System.Address; ! arg1 : System.Address; ! arg2 : int := 0; ! arg3 : int := 0; ! arg4 : int := 0; ! arg5 : int := 0; ! arg6 : int := 0; ! arg7 : int := 0; ! arg8 : int := 0; ! arg9 : int := 0; ! arg10 : int := 0) return t_id; ! pragma Import (C, taskSpawn, "taskSpawn"); ! procedure taskDelete (tid : t_id); ! pragma Import (C, taskDelete, "taskDelete"); ! function kernelTimeSlice (ticks : int) return int; ! pragma Import (C, kernelTimeSlice, "kernelTimeSlice"); ! function taskPrioritySet ! (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. *************** package System.OS_Interface is *** 461,467 **** SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore ! -- Semaphore initial state flags; SEM_EMPTY : constant := 0; SEM_FULL : constant := 1; --- 301,307 ---- SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore ! -- Semaphore initial state flags SEM_EMPTY : constant := 0; SEM_FULL : constant := 1; *************** package System.OS_Interface is *** 471,506 **** WAIT_FOREVER : constant := -1; NO_WAIT : constant := 0; ! type SEM_ID is new long; ! -- The VxWorks semaphore ID is an integer which is really just ! -- a pointer to a semaphore structure. ! function semBCreate (Options : int; Initial_State : int) return SEM_ID; ! -- Create a binary semaphore. Returns ID, or 0 if memory could not ! -- be allocated pragma Import (C, semBCreate, "semBCreate"); ! function semTake (SemID : SEM_ID; Timeout : int) return STATUS; -- Attempt to take binary semaphore. Error is returned if operation -- times out pragma Import (C, semTake, "semTake"); - function semGive (SemID : SEM_ID) return STATUS; - -- Release one thread blocked on the semaphore - pragma Import (C, semGive, "semGive"); - function semFlush (SemID : SEM_ID) return STATUS; -- Release all threads blocked on the semaphore pragma Import (C, semFlush, "semFlush"); ! function semDelete (SemID : SEM_ID) return STATUS; ! -- Delete a semaphore ! pragma Import (C, semDelete, "semDelete"); private - -- This interface assumes that "unsigned" and "int" are 32-bit entities. - type sigset_t is new long; type pid_t is new int; --- 311,367 ---- WAIT_FOREVER : constant := -1; NO_WAIT : constant := 0; ! -- Error codes (errno). The lower level 16 bits are the ! -- error code, with the upper 16 bits representing the ! -- module number in which the error occurred. By convention, ! -- the module number is 0 for UNIX errors. VxWorks reserves ! -- module numbers 1-500, with the remaining module numbers ! -- being available for user applications. ! M_objLib : constant := 61 * 2**16; ! -- semTake() failure with ticks = NO_WAIT ! S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; ! -- semTake() timeout with ticks > NO_WAIT ! S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; ! ! type SEM_ID is new System.Address; ! -- typedef struct semaphore *SEM_ID; ! ! -- We use two different kinds of VxWorks semaphores: mutex ! -- and binary semaphores. A null ID is returned when ! -- a semaphore cannot be created. ! ! function semBCreate (options : int; initial_state : int) return SEM_ID; ! -- Create a binary semaphore. Return ID, or 0 if memory could not ! -- be allocated. pragma Import (C, semBCreate, "semBCreate"); ! function semMCreate (options : int) return SEM_ID; ! pragma Import (C, semMCreate, "semMCreate"); ! ! function semDelete (Sem : SEM_ID) return int; ! -- Delete a semaphore ! pragma Import (C, semDelete, "semDelete"); ! ! function semGive (Sem : SEM_ID) return int; ! pragma Import (C, semGive, "semGive"); ! ! function semTake (Sem : SEM_ID; timeout : int) return int; -- Attempt to take binary semaphore. Error is returned if operation -- times out pragma Import (C, semTake, "semTake"); function semFlush (SemID : SEM_ID) return STATUS; -- Release all threads blocked on the semaphore pragma Import (C, semFlush, "semFlush"); ! function taskLock return int; ! pragma Import (C, taskLock, "taskLock"); + function taskUnlock return int; + pragma Import (C, taskUnlock, "taskUnlock"); private type sigset_t is new long; type pid_t is new int; *************** private *** 510,558 **** type clockid_t is new int; CLOCK_REALTIME : constant clockid_t := 0; - -- Priority ceilings are now implemented in the body of - -- this package. - - type pthread_mutexattr_t is record - Flags : int; -- mutex semaphore creation flags - Prio_Ceiling : int; -- priority ceiling - Protocol : int; - end record; - - type pthread_mutex_t is record - Mutex : SEM_ID; - Protocol : int; - Prio_Ceiling : int; -- priority ceiling of lock - end record; - - type pthread_condattr_t is record - Flags : int; - end record; - - type pthread_cond_t is record - Sem : SEM_ID; -- VxWorks semaphore ID - Waiting : Integer; -- Number of queued tasks waiting - end record; - - type pthread_attr_t is record - Stacksize : size_t; - Detachstate : int; - Priority : int; - Taskname : System.Address; - end record; - - type pthread_t is new long; - - null_pthread : constant pthread_t := 0; - - type pthread_key_t is new int; - - -- These are to store the pthread_keys that are created with - -- pthread_key_create. Currently, we only need one key. - - Key_Storage : array (1 .. 10) of aliased System.Address; - Keys_Created : Integer; - - Time_Slice : int; - end System.OS_Interface; --- 371,374 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5zosprim.adb gcc-3.3/gcc/ada/5zosprim.adb *** gcc-3.2.3/gcc/ada/5zosprim.adb 2002-05-04 03:27:18.000000000 +0000 --- gcc-3.3/gcc/ada/5zosprim.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5zparame.ads gcc-3.3/gcc/ada/5zparame.ads *** gcc-3.2.3/gcc/ada/5zparame.ads 2002-05-04 03:27:18.000000000 +0000 --- gcc-3.3/gcc/ada/5zparame.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,135 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- S Y S T E M . P A R A M E T E R S -- - -- -- - -- S p e c -- - -- -- - -- $Revision: 1.1.16.1 $ - -- -- - -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- - -- -- - -- GNAT is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is the VxWorks/68k version of this 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; - -- Secondary_Stack_Ratio is a constant between 0 and 100 wich - -- determines the percentage of the allocate 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 := -1; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; - -- Convenient Boolean for testing for dynmaic 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 - - 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) - - end System.Parameters; --- 0 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/5zsystem.ads gcc-3.3/gcc/ada/5zsystem.ads *** gcc-3.2.3/gcc/ada/5zsystem.ads 2002-05-04 03:27:18.000000000 +0000 --- gcc-3.3/gcc/ada/5zsystem.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 5,15 **** -- S Y S T E M -- -- -- -- S p e c -- ! -- (VXWORKS Version Alpha, Mips) -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Pure (System); *** 60,75 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := Standard'Tick; -- Storage-related Declarations type Address is private; Null_Address : constant Address; ! Storage_Unit : constant := Standard'Storage_Unit; ! Word_Size : constant := Standard'Word_Size; ! Memory_Size : constant := 2 ** Standard'Address_Size; -- Address comparison --- 59,74 ---- 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 := 64; ! Memory_Size : constant := 2 ** 64; -- Address comparison *************** pragma Pure (System); *** 88,127 **** -- Other System-Dependent Declarations type Bit_Order is (High_Order_First, Low_Order_First); ! Default_Bit_Order : constant Bit_Order := ! Bit_Order'Val (Standard'Default_Bit_Order); -- 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 .. Standard'Max_Interrupt_Priority; ! ! subtype Priority is Any_Priority ! range 0 .. Standard'Max_Priority; ! ! -- Functional notation is needed in the following to avoid visibility ! -- problems when this package is compiled through rtsfind in the middle ! -- of another compilation. ! ! subtype Interrupt_Priority is Any_Priority ! range ! Standard."+" (Standard'Max_Priority, 1) .. ! Standard'Max_Interrupt_Priority; ! Default_Priority : constant Priority := ! Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); private --- 87,112 ---- -- 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 *************** private *** 139,157 **** -- of the individual switch values. AAMP : constant Boolean := False; Command_Line_Args : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Default : constant Boolean := False; Denorm : constant Boolean := False; ! Machine_Rounds : constant Boolean := True; Machine_Overflows : constant Boolean := False; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; ! Long_Shifts_Inlined : constant Boolean := False; ! High_Integrity_Mode : constant Boolean := False; ! Functions_Return_By_DSP : constant Boolean := False; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; --- 124,145 ---- -- 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; 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/5ztaprop.adb gcc-3.3/gcc/ada/5ztaprop.adb *** gcc-3.2.3/gcc/ada/5ztaprop.adb 2001-12-16 01:13:30.000000000 +0000 --- gcc-3.3/gcc/ada/5ztaprop.adb 2002-10-23 08:27:55.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** pragma Polling (Off); *** 46,55 **** with System.Tasking.Debug; -- used for Known_Tasks - with Interfaces.C; - -- used for int - -- size_t - with System.Interrupt_Management; -- used for Keep_Unmasked -- Abort_Task_Interrupt --- 44,49 ---- *************** with System.Tasking; *** 78,88 **** with System.Task_Info; -- used for Task_Image ! with System.OS_Primitives; ! -- used for Delay_Modes ! ! with System.VxWorks; ! -- used for TASK_DESC with Unchecked_Conversion; with Unchecked_Deallocation; --- 72,78 ---- with System.Task_Info; -- used for Task_Image ! with Interfaces.C; with Unchecked_Conversion; with Unchecked_Deallocation; *************** package body System.Task_Primitives.Oper *** 92,116 **** use System.Tasking.Debug; use System.Tasking; use System.Task_Info; - 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. ! ATCB_Key : aliased pthread_key_t; ! -- Key used to find the Ada Task_ID associated with a VxWorks task. ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 82,112 ---- use System.Tasking.Debug; use System.Tasking; use System.Task_Info; use System.OS_Interface; use System.Parameters; ! use type Interfaces.C.int; package SSL renames System.Soft_Links; ! subtype int is System.OS_Interface.int; ! ! Relative : constant := 0; ! ! ---------------- ! -- Local Data -- ! ---------------- -- 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. *************** package body System.Task_Primitives.Oper *** 132,141 **** FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; -- Indicates whether FIFO_Within_Priorities is set. ! Mutex_Protocol : Interfaces.C.int; ! ! Stack_Limit : aliased System.Address; ! pragma Import (C, Stack_Limit, "__gnat_stack_limit"); ----------------------- -- Local Subprograms -- --- 128,134 ---- FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; -- Indicates whether FIFO_Within_Priorities is set. ! Mutex_Protocol : Priority_Type; ----------------------- -- Local Subprograms -- *************** package body System.Task_Primitives.Oper *** 143,150 **** procedure Abort_Handler (signo : Signal); - function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); ------------------- --- 136,141 ---- *************** package body System.Task_Primitives.Oper *** 153,165 **** procedure Abort_Handler (signo : Signal) is Self_ID : constant Task_ID := Self; ! Result : Interfaces.C.int; Old_Set : aliased sigset_t; 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 then Self_ID.Aborting := True; --- 144,156 ---- procedure Abort_Handler (signo : Signal) is Self_ID : constant Task_ID := Self; ! Result : int; Old_Set : aliased sigset_t; 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 then Self_ID.Aborting := True; *************** package body System.Task_Primitives.Oper *** 178,194 **** ----------------- procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - Task_Descriptor : aliased System.VxWorks.TASK_DESC; - Result : Interfaces.C.int; - begin ! if On then ! Result := taskInfoGet (T.Common.LL.Thread, ! Task_Descriptor'Unchecked_Access); ! pragma Assert (Result = 0); ! ! Stack_Limit := Task_Descriptor.td_pStackLimit; ! end if; end Stack_Guard; ------------------- --- 169,177 ---- ----------------- procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is begin ! -- Nothing needed. ! null; end Stack_Guard; ------------------- *************** package body System.Task_Primitives.Oper *** 205,216 **** ---------- 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; ----------------------------- --- 188,196 ---- ---------- function Self return Task_ID is begin ! pragma Assert (Current_Task /= null); ! return Current_Task; end Self; ----------------------------- *************** package body System.Task_Primitives.Oper *** 218,230 **** ----------------------------- procedure Install_Signal_Handlers; ! pragma Inline (Install_Signal_Handlers); procedure Install_Signal_Handlers is act : aliased struct_sigaction; old_act : aliased struct_sigaction; Tmp_Set : aliased sigset_t; ! Result : Interfaces.C.int; begin act.sa_flags := 0; --- 198,210 ---- ----------------------------- 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; *************** package body System.Task_Primitives.Oper *** 248,323 **** -- 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 All_Tasks_Lock, Memory_Lock...) ! -- used in RTS is initialized before any status change of RTS. ! -- Therefore rasing Storage_Error in the following routines ! -- should be able to be handled safely. ! ! procedure Initialize_Lock ! (Prio : System.Any_Priority; ! L : access Lock) ! is ! Attributes : aliased pthread_mutexattr_t; ! Result : Interfaces.C.int; begin ! Result := pthread_mutexattr_init (Attributes'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! ! if Result = ENOMEM then ! raise Storage_Error; ! end if; ! ! Result := pthread_mutexattr_setprotocol ! (Attributes'Access, Mutex_Protocol); ! pragma Assert (Result = 0); ! ! Result := pthread_mutexattr_setprioceiling ! (Attributes'Access, Interfaces.C.int (Prio)); ! pragma Assert (Result = 0); ! ! Result := pthread_mutex_init (L, 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 - 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_mutexattr_setprotocol ! (Attributes'Access, Mutex_Protocol); ! pragma Assert (Result = 0); ! ! Result := pthread_mutexattr_setprioceiling ! (Attributes'Access, ! Interfaces.C.int (System.Any_Priority'Last)); ! pragma Assert (Result = 0); ! ! Result := pthread_mutex_init (L, 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; ------------------- --- 228,247 ---- -- Initialize_Lock -- --------------------- ! procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is begin ! L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); ! L.Prio_Ceiling := int (Prio); ! L.Protocol := Mutex_Protocol; ! pragma Assert (L.Mutex /= 0); end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is begin ! L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); ! L.Prio_Ceiling := int (System.Any_Priority'Last); ! L.Protocol := Mutex_Protocol; ! pragma Assert (L.Mutex /= 0); end Initialize_Lock; ------------------- *************** package body System.Task_Primitives.Oper *** 325,342 **** ------------------- procedure Finalize_Lock (L : access Lock) is ! Result : Interfaces.C.int; ! begin ! Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); end Finalize_Lock; procedure Finalize_Lock (L : access RTS_Lock) is ! Result : Interfaces.C.int; ! begin ! Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); end Finalize_Lock; --- 249,264 ---- ------------------- procedure Finalize_Lock (L : access Lock) is ! Result : int; begin ! Result := semDelete (L.Mutex); pragma Assert (Result = 0); end Finalize_Lock; procedure Finalize_Lock (L : access RTS_Lock) is ! Result : int; begin ! Result := semDelete (L.Mutex); pragma Assert (Result = 0); end Finalize_Lock; *************** package body System.Task_Primitives.Oper *** 345,375 **** ---------------- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is ! Result : Interfaces.C.int; ! begin ! Result := pthread_mutex_lock (L); ! ! -- 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; ! procedure Write_Lock (L : access RTS_Lock) is ! Result : Interfaces.C.int; ! begin ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is ! Result : Interfaces.C.int; ! begin ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Write_Lock; --------------- --- 267,305 ---- ---------------- 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 ! then ! Ceiling_Violation := True; ! return; ! else ! Ceiling_Violation := False; ! end if; ! Result := semTake (L.Mutex, WAIT_FOREVER); ! pragma Assert (Result = 0); 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); ! pragma Assert (Result = 0); ! end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is ! Result : int; begin ! if not Single_Lock then ! Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); ! pragma Assert (Result = 0); ! end if; end Write_Lock; --------------- *************** package body System.Task_Primitives.Oper *** 386,430 **** ------------ procedure Unlock (L : access Lock) is ! Result : Interfaces.C.int; ! begin ! Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock) is ! Result : Interfaces.C.int; ! begin ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is ! Result : Interfaces.C.int; ! begin ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Unlock; ! ------------- ! -- Sleep -- ! ------------- ! ! procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) is ! Result : Interfaces.C.int; begin pragma Assert (Self_ID = Self); - Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access); ! -- EINTR is not considered a failure. ! pragma Assert (Result = 0 or else Result = EINTR); end Sleep; ----------------- --- 316,397 ---- ------------ procedure Unlock (L : access Lock) is ! Result : int; begin ! Result := semGive (L.Mutex); pragma Assert (Result = 0); end Unlock; ! 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); ! pragma Assert (Result = 0); ! end if; end Unlock; procedure Unlock (T : Task_ID) is ! Result : int; begin ! if not Single_Lock then ! Result := semGive (T.Common.LL.L.Mutex); ! pragma Assert (Result = 0); ! end if; end Unlock; ! ----------- ! -- Sleep -- ! ----------- + 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 ! 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, 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 ! Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); ! end if; ! ! pragma Assert (Result = 0); ! ! -- Reenable task scheduling. ! ! Result := taskUnlock; end Sleep; ----------------- *************** package body System.Task_Primitives.Oper *** 443,484 **** Timedout : out Boolean; Yielded : out Boolean) is ! Check_Time : constant Duration := Monotonic_Clock; ! 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; else ! Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); end if; ! if Abs_Time > Check_Time then ! Request := To_Timespec (Abs_Time); ! loop ! exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level ! or else Self_ID.Pending_Priority_Change; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); ! Yielded := True; ! 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; --- 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; *************** package body System.Task_Primitives.Oper *** 487,522 **** ----------------- -- 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; ! Request : aliased timespec; ! Result : Interfaces.C.int; ! Yielded : Boolean := False; 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; ! Write_Lock (Self_ID); if Mode = Relative then ! Abs_Time := Time + Check_Time; else ! Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); end if; ! if Abs_Time > Check_Time then ! Request := To_Timespec (Abs_Time); Self_ID.Common.State := Delay_Sleep; loop --- 490,537 ---- ----------------- -- This is for use in implementing delay statements, so ! -- we assume the caller is holding no locks. procedure Timed_Delay (Self_ID : Task_ID; Time : Duration; Mode : ST.Delay_Modes) is ! Orig : constant Duration := Monotonic_Clock; ! Absolute : Duration; ! 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 *************** package body System.Task_Primitives.Oper *** 528,551 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); ! Yielded := True; ! 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 not Yielded then ! Result := sched_yield; end if; SSL.Abort_Undefer.all; end Timed_Delay; --- 543,603 ---- 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 ! Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); ! end if; ! ! 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; *************** package body System.Task_Primitives.Oper *** 555,561 **** function Monotonic_Clock return Duration is TS : aliased timespec; ! Result : Interfaces.C.int; begin Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); pragma Assert (Result = 0); --- 607,614 ---- function Monotonic_Clock return Duration is TS : aliased timespec; ! Result : int; ! begin Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 576,586 **** ------------ 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); end Wakeup; ----------- --- 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; ----------- *************** package body System.Task_Primitives.Oper *** 588,597 **** ----------- procedure Yield (Do_Yield : Boolean := True) is ! Result : Interfaces.C.int; ! begin ! Result := sched_yield; end Yield; ------------------ --- 660,668 ---- ----------- procedure Yield (Do_Yield : Boolean := True) is ! Result : int; begin ! Result := taskDelay (0); end Yield; ------------------ *************** package body System.Task_Primitives.Oper *** 613,637 **** Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is - Param : aliased struct_sched_param; Array_Item : Integer; ! Result : Interfaces.C.int; begin ! Param.sched_priority := Interfaces.C.int (Prio); ! ! if 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_RR, Param'Access); ! end if; ! 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 --- 684,698 ---- 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 *** 676,693 **** ---------------- procedure Enter_Task (Self_ID : Task_ID) is ! Result : Interfaces.C.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 := pthread_self; ! ! Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); ! pragma Assert (Result = 0); ! Init_Float; -- Install the signal handlers. --- 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. *************** package body System.Task_Primitives.Oper *** 696,712 **** Install_Signal_Handlers; ! Lock_All_Tasks_List; ! for T in Known_Tasks'Range loop ! if Known_Tasks (T) = null then ! Known_Tasks (T) := Self_ID; ! Self_ID.Known_Tasks_Index := T; exit; end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 755,771 ---- Install_Signal_Handlers; ! 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; -------------- *************** package body System.Task_Primitives.Oper *** 718,787 **** 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 ! Self_ID.Common.LL.Thread := null_pthread; ! ! Result := pthread_mutexattr_init (Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! ! if Result /= 0 then ! Succeeded := False; ! return; ! end if; ! ! Result := pthread_mutexattr_setprotocol ! (Mutex_Attr'Access, Mutex_Protocol); ! 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); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! ! if Result /= 0 then ! Succeeded := False; ! return; ! end if; ! ! Result := pthread_mutexattr_destroy (Mutex_Attr'Access); ! pragma Assert (Result = 0); ! ! Result := pthread_condattr_init (Cond_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); Succeeded := False; - return; - end if; - - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Succeeded := True; else ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! Succeeded := False; ! end if; ! Result := pthread_condattr_destroy (Cond_Attr'Access); ! pragma Assert (Result = 0); end Initialize_TCB; ----------------- --- 777,801 ---- 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; ! if not Single_Lock then ! Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); ! end if; ! end if; end Initialize_TCB; ----------------- *************** package body System.Task_Primitives.Oper *** 797,818 **** is use type System.Task_Info.Task_Image_Type; ! Adjusted_Stack_Size : Interfaces.C.size_t; ! Attributes : aliased pthread_attr_t; ! Result : Interfaces.C.int; ! ! function Thread_Body_Access is new ! 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; -- Ask for 4 extra bytes of stack space so that the ATCB --- 811,827 ---- 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); elsif Stack_Size < Minimum_Stack_Size then ! Adjusted_Stack_Size := size_t (Minimum_Stack_Size); else ! Adjusted_Stack_Size := size_t (Stack_Size); end if; -- Ask for 4 extra bytes of stack space so that the ATCB *************** package body System.Task_Primitives.Oper *** 821,827 **** -- gets the amount of stack requested exclusive of the needs -- of the runtime. -- ! -- We also have to allocate 10 more bytes for the task name -- storage and enough space for the Wind Task Control Block -- which is around 0x778 bytes. VxWorks also seems to carve out -- additional space, so use 2048 as a nice round number. --- 830,836 ---- -- gets the amount of stack requested exclusive of the needs -- of the runtime. -- ! -- We also have to allocate n more bytes for the task name -- storage and enough space for the Wind Task Control Block -- which is around 0x778 bytes. VxWorks also seems to carve out -- additional space, so use 2048 as a nice round number. *************** package body System.Task_Primitives.Oper *** 832,890 **** -- set the task name to something appropriate. Adjusted_Stack_Size := Adjusted_Stack_Size + 2048; ! 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); ! -- Let's check to see if the task has an image string and ! -- use that as the VxWorks task name. ! if T.Common.Task_Image /= null then declare ! Task_Name : aliased constant String := ! T.Common.Task_Image.all & ASCII.NUL; begin ! Result := pthread_attr_setname_np ! (Attributes'Access, Task_Name'Address); ! -- 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)); end; - else - -- No specified task name - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); end if; - pragma Assert (Result = 0); - - Succeeded := Result = 0; ! Result := pthread_attr_destroy (Attributes'Access); ! pragma Assert (Result = 0); Task_Creation_Hook (T.Common.LL.Thread); - Set_Priority (T, Priority); end Create_Task; --- 841,883 ---- -- 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 ! -- 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. ! if T.Common.Task_Image = null then ! T.Common.LL.Thread := taskSpawn ! (System.Null_Address, ! To_VxWorks_Priority (int (Priority)), ! VX_FP_TASK, ! Adjusted_Stack_Size, ! Wrapper, ! 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 ! (Name'Address, ! To_VxWorks_Priority (int (Priority)), ! VX_FP_TASK, ! Adjusted_Stack_Size, ! Wrapper, To_Address (T)); end; end if; ! if T.Common.LL.Thread = -1 then ! Succeeded := False; ! else ! Succeeded := True; ! end if; Task_Creation_Hook (T.Common.LL.Thread); Set_Priority (T, Priority); end Create_Task; *************** package body System.Task_Primitives.Oper *** 893,911 **** ------------------ 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); begin ! T.Common.LL.Thread := null_pthread; ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); if T.Known_Tasks_Index /= -1 then --- 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 *************** package body System.Task_Primitives.Oper *** 922,928 **** procedure Exit_Task is begin Task_Termination_Hook; ! pthread_exit (System.Null_Address); end Exit_Task; ---------------- --- 917,923 ---- procedure Exit_Task is begin Task_Termination_Hook; ! taskDelete (0); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 930,936 **** ---------------- procedure Abort_Task (T : Task_ID) is ! Result : Interfaces.C.int; begin Result := kill (T.Common.LL.Thread, Signal (Interrupt_Management.Abort_Task_Interrupt)); --- 925,931 ---- ---------------- procedure Abort_Task (T : Task_ID) is ! Result : int; begin Result := kill (T.Common.LL.Thread, Signal (Interrupt_Management.Abort_Task_Interrupt)); *************** package body System.Task_Primitives.Oper *** 941,947 **** -- Check_Exit -- ---------------- ! -- Dummy versions. The only currently working versions is for solaris -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is --- 936,942 ---- -- Check_Exit -- ---------------- ! -- Dummy versions. The only currently working version is for solaris -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is *************** package body System.Task_Primitives.Oper *** 967,989 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 962,984 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 993,999 **** (T : ST.Task_ID; Thread_Self : Thread_Id) return Boolean is begin ! if T.Common.LL.Thread /= null_pthread and then T.Common.LL.Thread /= Thread_Self then return taskSuspend (T.Common.LL.Thread) = 0; --- 988,994 ---- (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 then return taskSuspend (T.Common.LL.Thread) = 0; *************** package body System.Task_Primitives.Oper *** 1010,1016 **** (T : ST.Task_ID; Thread_Self : Thread_Id) return Boolean is begin ! if T.Common.LL.Thread /= null_pthread and then T.Common.LL.Thread /= Thread_Self then return taskResume (T.Common.LL.Thread) = 0; --- 1005,1011 ---- (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 then return taskResume (T.Common.LL.Thread) = 0; *************** package body System.Task_Primitives.Oper *** 1029,1073 **** -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); Enter_Task (Environment_Task); end Initialize; begin declare ! Result : Interfaces.C.int; ! begin if Locking_Policy = 'C' then ! Mutex_Protocol := PTHREAD_PRIO_PROTECT; else ! -- We default to VxWorks native priority inheritence ! -- and inversion safe mutexes with no ceiling checks. ! Mutex_Protocol := PTHREAD_PRIO_INHERIT; end if; if Time_Slice_Val > 0 then ! Result := pthread_sched_rr_set_interval ! (Interfaces.C.int (Time_Slice_Val)); end if; - -- 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 Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0); - - Result := taskVarAdd (getpid, Stack_Limit'Access); - pragma Assert (Result = 0); end; end System.Task_Primitives.Operations; --- 1024,1053 ---- -- 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; ! elsif Locking_Policy = 'I' then ! Mutex_Protocol := Prio_Inherit; else ! Mutex_Protocol := Prio_None; end if; if Time_Slice_Val > 0 then ! Result := kernelTimeSlice ! (To_Clock_Ticks ! (Duration (Time_Slice_Val) / Duration (1_000_000.0))); end if; Result := sigemptyset (Unblocked_Signal_Mask'Access); pragma Assert (Result = 0); end; end System.Task_Primitives.Operations; diff -Nrc3pad gcc-3.2.3/gcc/ada/6vcpp.adb gcc-3.3/gcc/ada/6vcpp.adb *** gcc-3.2.3/gcc/ada/6vcpp.adb 2002-05-04 03:27:19.000000000 +0000 --- gcc-3.3/gcc/ada/6vcpp.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 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,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- -- *************** package body Interfaces.CPP is *** 76,88 **** function To_Type_Specific_Data_Ptr is new Unchecked_Conversion (Address, Type_Specific_Data_Ptr); - function To_Address is new Unchecked_Conversion (Vtable_Ptr, Address); function To_Address is new Unchecked_Conversion (Type_Specific_Data_Ptr, Address); - function To_Vtable_Ptr is new Unchecked_Conversion (Tag, Vtable_Ptr); - function To_Tag is new Unchecked_Conversion (Vtable_Ptr, Tag); - --------------------------------------------- -- Unchecked Conversions for String Fields -- --------------------------------------------- --- 75,83 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/6vcstrea.adb gcc-3.3/gcc/ada/6vcstrea.adb *** gcc-3.2.3/gcc/ada/6vcstrea.adb 2002-05-04 03:27:19.000000000 +0000 --- gcc-3.3/gcc/ada/6vcstrea.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1996-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,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- -- *************** *** 35,40 **** --- 34,40 ---- -- This is the Alpha/VMS version. + with Unchecked_Conversion; package body Interfaces.C_Streams is ------------ diff -Nrc3pad gcc-3.2.3/gcc/ada/6vinterf.ads gcc-3.3/gcc/ada/6vinterf.ads *** gcc-3.2.3/gcc/ada/6vinterf.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/6vinterf.ads 2002-03-14 10:58:43.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/7sinmaop.adb gcc-3.3/gcc/ada/7sinmaop.adb *** gcc-3.2.3/gcc/ada/7sinmaop.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/7sinmaop.adb 2002-03-14 10:58:43.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-1998, Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/7sintman.adb gcc-3.3/gcc/ada/7sintman.adb *** gcc-3.2.3/gcc/ada/7sintman.adb 2001-12-16 01:13:30.000000000 +0000 --- gcc-3.3/gcc/ada/7sintman.adb 2002-03-14 10:58:43.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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-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- -- *************** begin *** 189,201 **** act.sa_mask := Signal_Mask; Keep_Unmasked (Abort_Task_Interrupt) := True; - Keep_Unmasked (SIGXCPU) := True; - Keep_Unmasked (SIGFPE) := True; - Result := - sigaction - (Signal (SIGFPE), act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); -- 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 --- 188,193 ---- *************** begin *** 208,225 **** Keep_Unmasked (SIGINT) := True; end if; ! for J in ! Exception_Interrupts'First + 1 .. Exception_Interrupts'Last ! loop Keep_Unmasked (Exception_Interrupts (J)) := True; ! if Unreserve_All_Interrupts = 0 then ! Result := ! sigaction ! (Signal (Exception_Interrupts (J)), act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; end loop; for J in Unmasked'Range loop --- 200,213 ---- 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 diff -Nrc3pad gcc-3.2.3/gcc/ada/7sosinte.adb gcc-3.3/gcc/ada/7sosinte.adb *** gcc-3.2.3/gcc/ada/7sosinte.adb 2001-10-02 13:42:29.000000000 +0000 --- gcc-3.3/gcc/ada/7sosinte.adb 2002-03-14 10:58:44.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1997-2001 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/7sosprim.adb gcc-3.3/gcc/ada/7sosprim.adb *** gcc-3.2.3/gcc/ada/7sosprim.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/7sosprim.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/7staprop.adb gcc-3.3/gcc/ada/7staprop.adb *** gcc-3.2.3/gcc/ada/7staprop.adb 2001-12-16 01:13:30.000000000 +0000 --- gcc-3.3/gcc/ada/7staprop.adb 2002-10-23 08:27:55.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 101,115 **** package SSL renames System.Soft_Links; ! ------------------ ! -- Local Data -- ! ------------------ -- The followings are logically constants, but need to be initialized -- at run time. ! All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; ! -- See comments on locking rules in System.Tasking (spec). Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 99,115 ---- 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 Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 143,150 **** -- Local Subprograms -- ----------------------- ! procedure Abort_Handler ! (Sig : Signal); function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); --- 143,149 ---- -- Local Subprograms -- ----------------------- ! procedure Abort_Handler (Sig : Signal); function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); *************** package body System.Task_Primitives.Oper *** 252,266 **** -- Context.PC := Raise_Abort_Signal'Address; -- return; -- 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; --- 251,263 ---- -- Context.PC := Raise_Abort_Signal'Address; -- return; -- 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; *************** package body System.Task_Primitives.Oper *** 304,310 **** -- Note: mutexes and cond_variables needed per-task basis are -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as All_Tasks_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. --- 301,307 ---- -- 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. *************** package body System.Task_Primitives.Oper *** 395,401 **** procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); --- 392,397 ---- *************** package body System.Task_Primitives.Oper *** 403,409 **** procedure Finalize_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); --- 399,404 ---- *************** package body System.Task_Primitives.Oper *** 415,421 **** procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; - begin Result := pthread_mutex_lock (L); --- 410,415 ---- *************** package body System.Task_Primitives.Oper *** 425,444 **** pragma Assert (Result = 0 or else Result = EINVAL); end Write_Lock; ! procedure Write_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (L); ! pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_lock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Write_Lock; --------------- --- 419,442 ---- 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 ! 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; --------------- *************** package body System.Task_Primitives.Oper *** 456,495 **** procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); end Unlock; ! ------------- ! -- Sleep -- ! ------------- ! procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; - begin ! pragma Assert (Self_ID = Self); ! Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access); -- EINTR is not considered a failure. --- 454,499 ---- procedure Unlock (L : access Lock) is Result : Interfaces.C.int; begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); end Unlock; ! procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin ! if not Single_Lock or else Global_Lock then ! Result := pthread_mutex_unlock (L); ! pragma Assert (Result = 0); ! end if; end Unlock; procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; begin ! if not Single_Lock then ! Result := pthread_mutex_unlock (T.Common.LL.L'Access); ! pragma Assert (Result = 0); ! end if; end Unlock; ! ----------- ! -- Sleep -- ! ----------- ! procedure Sleep ! (Self_ID : 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. *************** package body System.Task_Primitives.Oper *** 548,555 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level or else Self_ID.Pending_Priority_Change; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; --- 552,567 ---- 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; *************** package body System.Task_Primitives.Oper *** 591,596 **** --- 603,613 ---- -- check for pending abort and priority change below! :( SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); if Mode = Relative then *************** package body System.Task_Primitives.Oper *** 626,633 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, Request'Access); exit when Abs_Time <= Monotonic_Clock; pragma Assert (Result = 0 --- 643,656 ---- 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 *************** package body System.Task_Primitives.Oper *** 639,644 **** --- 662,672 ---- end if; Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + Result := sched_yield; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 673,679 **** 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); --- 701,706 ---- *************** package body System.Task_Primitives.Oper *** 685,691 **** procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; - begin if Do_Yield then Result := sched_yield; --- 712,717 ---- *************** package body System.Task_Primitives.Oper *** 697,704 **** ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Result : Interfaces.C.int; --- 723,730 ---- ------------------ 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 *** 744,760 **** Specific.Set (Self_ID); ! Lock_All_Tasks_List; ! for I in Known_Tasks'Range loop ! if Known_Tasks (I) = null then ! Known_Tasks (I) := Self_ID; ! Self_ID.Known_Tasks_Index := I; exit; end if; end loop; ! Unlock_All_Tasks_List; end Enter_Task; -------------- --- 770,786 ---- 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; -------------- *************** package body System.Task_Primitives.Oper *** 772,779 **** 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. --- 798,805 ---- 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. *************** package body System.Task_Primitives.Oper *** 782,834 **** Next_Serial_Number := Next_Serial_Number + 1; pragma Assert (Next_Serial_Number /= 0); ! Result := pthread_mutexattr_init (Mutex_Attr'Access); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; ! end if; ! 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); ! pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Succeeded := False; ! return; end if; - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - Result := pthread_condattr_init (Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); ! Succeeded := False; ! return; end if; - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - if Result = 0 then Succeeded := True; else ! Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); ! pragma Assert (Result = 0); Succeeded := False; end if; --- 808,857 ---- 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_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); ! 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; *************** package body System.Task_Primitives.Oper *** 936,943 **** Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin ! Result := pthread_mutex_destroy (T.Common.LL.L'Access); ! pragma Assert (Result = 0); Result := pthread_cond_destroy (T.Common.LL.CV'Access); pragma Assert (Result = 0); --- 959,968 ---- 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); *************** package body System.Task_Primitives.Oper *** 1001,1023 **** return Environment_Task_ID; end Environment_Task; ! ------------------------- ! -- Lock_All_Tasks_List -- ! ------------------------- ! procedure Lock_All_Tasks_List is begin ! Write_Lock (All_Tasks_L'Access); ! end Lock_All_Tasks_List; ! --------------------------- ! -- Unlock_All_Tasks_List -- ! --------------------------- ! procedure Unlock_All_Tasks_List is begin ! Unlock (All_Tasks_L'Access); ! end Unlock_All_Tasks_List; ------------------ -- Suspend_Task -- --- 1026,1048 ---- 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 -- *************** package body System.Task_Primitives.Oper *** 1056,1062 **** -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); Specific.Initialize (Environment_Task); --- 1081,1087 ---- -- Initialize the lock used to synchronize chain of all ATCBs. ! Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); Specific.Initialize (Environment_Task); *************** package body System.Task_Primitives.Oper *** 1083,1089 **** 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 --- 1108,1113 ---- *************** begin *** 1104,1108 **** end if; end loop; end; - end System.Task_Primitives.Operations; --- 1128,1131 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/7staspri.ads gcc-3.3/gcc/ada/7staspri.ads *** gcc-3.2.3/gcc/ada/7staspri.ads 2001-10-02 13:42:29.000000000 +0000 --- gcc-3.3/gcc/ada/7staspri.ads 2002-03-14 10:58:44.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2000, Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/7stpopsp.adb gcc-3.3/gcc/ada/7stpopsp.adb *** gcc-3.2.3/gcc/ada/7stpopsp.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/7stpopsp.adb 2002-03-14 10:58:44.000000000 +0000 *************** *** 2,15 **** -- -- -- 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 -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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- -- --- 2,13 ---- -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- -- -- -- 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- -- *************** package body Specific is *** 68,74 **** --------- procedure Set (Self_Id : Task_ID) is ! Result : Interfaces.C.int; begin Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); --- 66,72 ---- --------- procedure Set (Self_Id : Task_ID) is ! Result : Interfaces.C.int; begin Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); diff -Nrc3pad gcc-3.2.3/gcc/ada/7straceb.adb gcc-3.3/gcc/ada/7straceb.adb *** gcc-3.2.3/gcc/ada/7straceb.adb 2001-10-02 13:42:29.000000000 +0000 --- gcc-3.3/gcc/ada/7straceb.adb 2002-03-14 10:58:44.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1999-2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/86numaux.adb gcc-3.3/gcc/ada/86numaux.adb *** gcc-3.2.3/gcc/ada/86numaux.adb 2002-05-04 03:27:19.000000000 +0000 --- gcc-3.3/gcc/ada/86numaux.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (Machine Version for x86) -- -- -- - -- $Revision: 1.3.10.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/86numaux.ads gcc-3.3/gcc/ada/86numaux.ads *** gcc-3.2.3/gcc/ada/86numaux.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/86numaux.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- (Machine Version for x86) -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/9drpc.adb gcc-3.3/gcc/ada/9drpc.adb *** gcc-3.2.3/gcc/ada/9drpc.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/9drpc.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.2 $ -- -- ! -- 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,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- -- *************** *** 33,38 **** --- 32,39 ---- -- -- ------------------------------------------------------------------------------ + -- Version for ??? + with Unchecked_Deallocation; with Ada.Streams; *************** pragma Elaborate (System.RPC.Garlic); *** 43,48 **** --- 44,53 ---- package body System.RPC is + -- ??? general note: the debugging calls are very heavy, especially + -- those that create exception handlers in every procedure. Do we + -- really still need all this stuff? + use type Ada.Streams.Stream_Element_Count; use type Ada.Streams.Stream_Element_Offset; *************** package body System.RPC is *** 52,58 **** Max_Of_Message_Id : constant := 127; subtype Message_Id_Type is ! Integer range -Max_Of_Message_Id .. Max_Of_Message_Id; -- A message id is either a request id or reply id. A message id is -- provided with a message to a receiving stub which uses the opposite -- as a reply id. A message id helps to retrieve to which task is --- 57,63 ---- Max_Of_Message_Id : constant := 127; subtype Message_Id_Type is ! Integer range -Max_Of_Message_Id .. Max_Of_Message_Id; -- A message id is either a request id or reply id. A message id is -- provided with a message to a receiving stub which uses the opposite -- as a reply id. A message id helps to retrieve to which task is *************** package body System.RPC is *** 67,75 **** type Message_Length_Per_Request is array (Request_Id_Type) of Ada.Streams.Stream_Element_Count; ! Header_Size : Ada.Streams.Stream_Element_Count ! := Streams.Get_Integer_Initial_Size + ! Streams.Get_SEC_Initial_Size; -- Initial size needed for frequently used header streams Stream_Error : exception; --- 72,80 ---- type Message_Length_Per_Request is array (Request_Id_Type) of Ada.Streams.Stream_Element_Count; ! Header_Size : Ada.Streams.Stream_Element_Count := ! Streams.Get_Integer_Initial_Size + ! Streams.Get_SEC_Initial_Size; -- Initial size needed for frequently used header streams Stream_Error : exception; *************** package body System.RPC is *** 94,126 **** Params_Size : in Ada.Streams.Stream_Element_Count; Result_Size : in Ada.Streams.Stream_Element_Count; Protocol : in Garlic.Protocol_Access); ! -- This entry provides an anonymous task a remote call to perform ! -- This task calls for a ! -- Request id is provided to construct the reply id by using ! -- -Request. Partition is used to send the reply message. Params_Size ! -- is the size of the calling stub Params stream. Then, Protocol ! -- (used by the environment task previously) allows to extract the ! -- message following the header (The header is extracted by the ! -- environment task) end Anonymous_Task_Type; type Anonymous_Task_Access is access Anonymous_Task_Type; ! type Anonymous_Task_List is ! record ! Head : Anonymous_Task_Node_Access; ! Tail : Anonymous_Task_Node_Access; ! end record; ! type Anonymous_Task_Node is ! record ! Element : Anonymous_Task_Access; ! Next : Anonymous_Task_Node_Access; ! end record; ! -- Types we need to construct a singly linked list of anonymous tasks ! -- This pool is maintained to avoid a task creation each time a RPC ! -- occurs protected Garbage_Collector is --- 99,128 ---- Params_Size : in Ada.Streams.Stream_Element_Count; Result_Size : in Ada.Streams.Stream_Element_Count; Protocol : in Garlic.Protocol_Access); ! -- This entry provides an anonymous task a remote call to perform. ! -- This task calls for a Request id is provided to construct the ! -- reply id by using -Request. Partition is used to send the reply ! -- message. Params_Size is the size of the calling stub Params stream. ! -- Then Protocol (used by the environment task previously) allows ! -- extraction of the message following the header (The header is ! -- extracted by the environment task) ! -- Note: grammar in above is obscure??? needs cleanup end Anonymous_Task_Type; type Anonymous_Task_Access is access Anonymous_Task_Type; ! type Anonymous_Task_List is record ! Head : Anonymous_Task_Node_Access; ! Tail : Anonymous_Task_Node_Access; ! end record; ! type Anonymous_Task_Node is record ! Element : Anonymous_Task_Access; ! Next : Anonymous_Task_Node_Access; ! end record; ! -- Types we need to construct a singly linked list of anonymous tasks. ! -- This pool is maintained to avoid a task creation each time a RPC occurs. protected Garbage_Collector is *************** package body System.RPC is *** 133,138 **** --- 135,141 ---- (Item : in out Anonymous_Task_Node_Access); -- Anonymous task pool management : queue this task in the pool -- of inactive anonymous tasks. + private Anonymous_List : Anonymous_Task_Node_Access; *************** package body System.RPC is *** 230,242 **** --------------- procedure Head_Node ! (Index : out Packet_Node_Access; ! Stream : in Params_Stream_Type) is begin Index := Stream.Extra.Head; ! exception when others => ! D (D_Exception, "exception in Head_Node"); ! raise; end Head_Node; --------------- --- 233,248 ---- --------------- procedure Head_Node ! (Index : out Packet_Node_Access; ! Stream : Params_Stream_Type) ! is begin Index := Stream.Extra.Head; ! ! exception ! when others => ! D (D_Exception, "exception in Head_Node"); ! raise; end Head_Node; --------------- *************** package body System.RPC is *** 244,277 **** --------------- procedure Tail_Node ! (Index : out Packet_Node_Access; ! Stream : in Params_Stream_Type) is begin Index := Stream.Extra.Tail; ! exception when others => ! D (D_Exception, "exception in Tail_Node"); ! raise; end Tail_Node; --------------- -- Null_Node -- --------------- ! function Null_Node ! (Index : in Packet_Node_Access) return Boolean is begin return Index = null; ! exception when others => ! D (D_Exception, "exception in Null_Node"); ! raise; end Null_Node; ---------------------- -- Delete_Head_Node -- ---------------------- ! procedure Delete_Head_Node ! (Stream : in out Params_Stream_Type) is procedure Free is new Unchecked_Deallocation --- 250,286 ---- --------------- procedure Tail_Node ! (Index : out Packet_Node_Access; ! Stream : Params_Stream_Type) ! is begin Index := Stream.Extra.Tail; ! ! exception ! when others => ! D (D_Exception, "exception in Tail_Node"); ! raise; end Tail_Node; --------------- -- Null_Node -- --------------- ! function Null_Node (Index : in Packet_Node_Access) return Boolean is begin return Index = null; ! ! exception ! when others => ! D (D_Exception, "exception in Null_Node"); ! raise; end Null_Node; ---------------------- -- Delete_Head_Node -- ---------------------- ! procedure Delete_Head_Node (Stream : in out Params_Stream_Type) is procedure Free is new Unchecked_Deallocation *************** package body System.RPC is *** 280,286 **** Next_Node : Packet_Node_Access := Stream.Extra.Head.Next; begin - -- Delete head node and free memory usage Free (Stream.Extra.Head); --- 289,294 ---- *************** package body System.RPC is *** 292,310 **** Stream.Extra.Tail := null; end if; ! exception when others => ! D (D_Exception, "exception in Delete_Head_Node"); ! raise; end Delete_Head_Node; --------------- -- Next_Node -- --------------- ! procedure Next_Node ! (Node : in out Packet_Node_Access) is begin - -- Node is set to the next node -- If not possible, Stream_Error is raised --- 300,317 ---- Stream.Extra.Tail := null; end if; ! exception ! when others => ! D (D_Exception, "exception in Delete_Head_Node"); ! raise; end Delete_Head_Node; --------------- -- Next_Node -- --------------- ! procedure Next_Node (Node : in out Packet_Node_Access) is begin -- Node is set to the next node -- If not possible, Stream_Error is raised *************** package body System.RPC is *** 314,333 **** Node := Node.Next; end if; ! exception when others => ! D (D_Exception, "exception in Next_Node"); ! raise; end Next_Node; --------------------- -- Append_New_Node -- --------------------- ! procedure Append_New_Node ! (Stream : in out Params_Stream_Type) is Index : Packet_Node_Access; - begin -- Set Index to the end of the linked list Tail_Node (Index, Stream); --- 321,340 ---- Node := Node.Next; end if; ! exception ! when others => ! D (D_Exception, "exception in Next_Node"); ! raise; end Next_Node; --------------------- -- Append_New_Node -- --------------------- ! procedure Append_New_Node (Stream : in out Params_Stream_Type) is Index : Packet_Node_Access; + begin -- Set Index to the end of the linked list Tail_Node (Index, Stream); *************** package body System.RPC is *** 340,346 **** Stream.Extra.Tail := Stream.Extra.Head; else - -- The list is not empty : link new node with tail Stream.Extra.Tail.Next := new Packet_Node; --- 347,352 ---- *************** package body System.RPC is *** 348,356 **** end if; ! exception when others => ! D (D_Exception, "exception in Append_New_Node"); ! raise; end Append_New_Node; ---------- --- 354,363 ---- end if; ! exception ! when others => ! D (D_Exception, "exception in Append_New_Node"); ! raise; end Append_New_Node; ---------- *************** package body System.RPC is *** 360,367 **** procedure Read (Stream : in out Params_Stream_Type; Item : out Ada.Streams.Stream_Element_Array; ! Last : out Ada.Streams.Stream_Element_Offset) renames ! System.RPC.Streams.Read; ----------- -- Write -- --- 367,374 ---- procedure Read (Stream : in out Params_Stream_Type; Item : out Ada.Streams.Stream_Element_Array; ! Last : out Ada.Streams.Stream_Element_Offset) ! renames System.RPC.Streams.Read; ----------- -- Write -- *************** package body System.RPC is *** 369,376 **** procedure Write (Stream : in out Params_Stream_Type; ! Item : in Ada.Streams.Stream_Element_Array) renames ! System.RPC.Streams.Write; ----------------------- -- Garbage_Collector -- --- 376,383 ---- procedure Write (Stream : in out Params_Stream_Type; ! Item : in Ada.Streams.Stream_Element_Array) ! renames System.RPC.Streams.Write; ----------------------- -- Garbage_Collector -- *************** package body System.RPC is *** 382,393 **** -- Garbage_Collector.Allocate -- -------------------------------- ! procedure Allocate ! (Item : out Anonymous_Task_Node_Access) is New_Anonymous_Task_Node : Anonymous_Task_Node_Access; Anonymous_Task : Anonymous_Task_Access; - begin -- If the list is empty, allocate a new anonymous task -- Otherwise, reuse the first queued anonymous task --- 389,399 ---- -- Garbage_Collector.Allocate -- -------------------------------- ! procedure Allocate (Item : out Anonymous_Task_Node_Access) is New_Anonymous_Task_Node : Anonymous_Task_Node_Access; Anonymous_Task : Anonymous_Task_Access; + begin -- If the list is empty, allocate a new anonymous task -- Otherwise, reuse the first queued anonymous task *************** package body System.RPC is *** 404,410 **** New_Anonymous_Task_Node.all := (Anonymous_Task, null); else - -- Extract one task from the list -- Set the Next field to null to avoid possible bugs --- 410,415 ---- *************** package body System.RPC is *** 418,444 **** Item := New_Anonymous_Task_Node; ! exception when others => ! D (D_Exception, "exception in Allocate (Anonymous Task)"); ! raise; end Allocate; ---------------------------------- -- Garbage_Collector.Deallocate -- ---------------------------------- ! procedure Deallocate ! (Item : in out Anonymous_Task_Node_Access) is begin - -- Enqueue the task in the free list Item.Next := Anonymous_List; Anonymous_List := Item; ! exception when others => ! D (D_Exception, "exception in Deallocate (Anonymous Task)"); ! raise; end Deallocate; end Garbage_Collector; --- 423,449 ---- Item := New_Anonymous_Task_Node; ! exception ! when others => ! D (D_Exception, "exception in Allocate (Anonymous Task)"); ! raise; end Allocate; ---------------------------------- -- Garbage_Collector.Deallocate -- ---------------------------------- ! procedure Deallocate (Item : in out Anonymous_Task_Node_Access) is begin -- Enqueue the task in the free list Item.Next := Anonymous_List; Anonymous_List := Item; ! exception ! when others => ! D (D_Exception, "exception in Deallocate (Anonymous Task)"); ! raise; end Deallocate; end Garbage_Collector; *************** package body System.RPC is *** 448,462 **** ------------ procedure Do_RPC ! (Partition : in Partition_ID; Params : access Params_Stream_Type; ! Result : access Params_Stream_Type) is Protocol : Protocol_Access; Request : Request_Id_Type; Header : aliased Params_Stream_Type (Header_Size); R_Length : Ada.Streams.Stream_Element_Count; - begin -- Parameters order : -- Opcode (provided and used by garlic) -- (1) Size (provided by s-rpc and used by garlic) --- 453,468 ---- ------------ procedure Do_RPC ! (Partition : Partition_ID; Params : access Params_Stream_Type; ! Result : access Params_Stream_Type) ! is Protocol : Protocol_Access; Request : Request_Id_Type; Header : aliased Params_Stream_Type (Header_Size); R_Length : Ada.Streams.Stream_Element_Count; + begin -- Parameters order : -- Opcode (provided and used by garlic) -- (1) Size (provided by s-rpc and used by garlic) *************** package body System.RPC is *** 538,544 **** declare New_Result : aliased Params_Stream_Type (R_Length); begin - -- Adjust the Result stream size right now to be able to load -- the stream in one receive call. Create a temporary resutl -- that will be substituted to Do_RPC one --- 544,549 ---- *************** package body System.RPC is *** 570,576 **** end; else - -- Do RPC locally and first wait for Partition_RPC_Receiver to be -- set --- 575,580 ---- *************** package body System.RPC is *** 580,588 **** end if; ! exception when others => ! D (D_Exception, "exception in Do_RPC"); ! raise; end Do_RPC; ------------ --- 584,593 ---- end if; ! exception ! when others => ! D (D_Exception, "exception in Do_RPC"); ! raise; end Do_RPC; ------------ *************** package body System.RPC is *** 590,602 **** ------------ procedure Do_APC ! (Partition : in Partition_ID; ! Params : access Params_Stream_Type) is Message_Id : Message_Id_Type := 0; Protocol : Protocol_Access; Header : aliased Params_Stream_Type (Header_Size); - begin -- For more informations, see above -- Request = 0 as we are not waiting for a reply message -- Result length = 0 as we don't expect a result at all --- 595,608 ---- ------------ procedure Do_APC ! (Partition : Partition_ID; ! Params : access Params_Stream_Type) ! is Message_Id : Message_Id_Type := 0; Protocol : Protocol_Access; Header : aliased Params_Stream_Type (Header_Size); + begin -- For more informations, see above -- Request = 0 as we are not waiting for a reply message -- Result length = 0 as we don't expect a result at all *************** package body System.RPC is *** 660,666 **** declare Result : aliased Params_Stream_Type (0); begin - -- Result is here a dummy parameter -- No reason to deallocate as it is not allocated at all --- 666,671 ---- *************** package body System.RPC is *** 672,700 **** end if; ! exception when others => ! D (D_Exception, "exception in Do_APC"); ! raise; end Do_APC; ---------------------------- -- Establish_RPC_Receiver -- ---------------------------- ! procedure Establish_RPC_Receiver ( ! Partition : in Partition_ID; ! Receiver : in RPC_Receiver) is begin - -- Set Partition_RPC_Receiver and allow RPC mechanism Partition_RPC_Receiver := Receiver; Partition_Receiver.Set; D (D_Elaborate, "Partition_Receiver is set"); ! exception when others => ! D (D_Exception, "exception in Establish_RPC_Receiver"); ! raise; end Establish_RPC_Receiver; ---------------- --- 677,707 ---- end if; ! exception ! when others => ! D (D_Exception, "exception in Do_APC"); ! raise; end Do_APC; ---------------------------- -- Establish_RPC_Receiver -- ---------------------------- ! procedure Establish_RPC_Receiver ! (Partition : in Partition_ID; ! Receiver : in RPC_Receiver) ! is begin -- Set Partition_RPC_Receiver and allow RPC mechanism Partition_RPC_Receiver := Receiver; Partition_Receiver.Set; D (D_Elaborate, "Partition_Receiver is set"); ! exception ! when others => ! D (D_Exception, "exception in Establish_RPC_Receiver"); ! raise; end Establish_RPC_Receiver; ---------------- *************** package body System.RPC is *** 705,728 **** Last_Request : Request_Id_Type := Request_Id_Type'First; Current_Rqst : Request_Id_Type := Request_Id_Type'First; Current_Size : Ada.Streams.Stream_Element_Count; - begin loop ! -- Three services : ! -- New_Request to get an entry in Dispatcher table ! -- Wait_On for Do_RPC calls ! -- Wake_Up called by environment task when a Do_RPC receives ! -- the result of its remote call ! select ! accept New_Request ! (Request : out Request_Id_Type) do Request := Last_Request; -- << TODO >> ! -- Avaibility check if Last_Request = Request_Id_Type'Last then Last_Request := Request_Id_Type'First; --- 712,735 ---- Last_Request : Request_Id_Type := Request_Id_Type'First; Current_Rqst : Request_Id_Type := Request_Id_Type'First; Current_Size : Ada.Streams.Stream_Element_Count; + begin loop + -- Three services: ! -- New_Request to get an entry in Dispatcher table ! -- Wait_On for Do_RPC calls ! -- Wake_Up called by environment task when a Do_RPC receives ! -- the result of its remote call ! ! select ! accept New_Request (Request : out Request_Id_Type) do Request := Last_Request; -- << TODO >> ! -- ??? Avaibility check if Last_Request = Request_Id_Type'Last then Last_Request := Request_Id_Type'First; *************** package body System.RPC is *** 733,743 **** end New_Request; or - accept Wake_Up ! (Request : in Request_Id_Type; ! Length : in Ada.Streams.Stream_Element_Count) do ! -- The environment reads the header and has been notified -- of the reply id and the size of the result message --- 740,749 ---- end New_Request; or accept Wake_Up ! (Request : Request_Id_Type; ! Length : Ada.Streams.Stream_Element_Count) ! do -- The environment reads the header and has been notified -- of the reply id and the size of the result message *************** package body System.RPC is *** 747,763 **** end Wake_Up; -- << TODO >> ! -- Must be select with delay for aborted tasks select accept Wait_On (Current_Rqst) ! (Length : out Ada.Streams.Stream_Element_Count) do Length := Current_Size; end Wait_On; or - -- To free the Dispatcher when a task is aborted delay 1.0; --- 753,769 ---- end Wake_Up; -- << TODO >> ! -- ??? Must be select with delay for aborted tasks select accept Wait_On (Current_Rqst) ! (Length : out Ada.Streams.Stream_Element_Count) ! do Length := Current_Size; end Wait_On; or -- To free the Dispatcher when a task is aborted delay 1.0; *************** package body System.RPC is *** 765,780 **** end select; or - terminate; - end select; end loop; ! exception when others => ! D (D_Exception, "exception in Dispatcher body"); ! raise; end Dispatcher; ------------------------- --- 771,785 ---- end select; or terminate; end select; end loop; ! exception ! when others => ! D (D_Exception, "exception in Dispatcher body"); ! raise; end Dispatcher; ------------------------- *************** package body System.RPC is *** 788,797 **** Params_S : Ada.Streams.Stream_Element_Count; -- Params message size Result_S : Ada.Streams.Stream_Element_Count; -- Result message size C_Protocol : Protocol_Access; -- Current Protocol - begin loop - -- Get a new RPC to execute select --- 793,801 ---- Params_S : Ada.Streams.Stream_Element_Count; -- Params message size Result_S : Ada.Streams.Stream_Element_Count; -- Result message size C_Protocol : Protocol_Access; -- Current Protocol + begin loop -- Get a new RPC to execute select *************** package body System.RPC is *** 800,806 **** Partition : in Partition_ID; Params_Size : in Ada.Streams.Stream_Element_Count; Result_Size : in Ada.Streams.Stream_Element_Count; ! Protocol : in Protocol_Access) do C_Message_Id := Message_Id; C_Partition := Partition; Params_S := Params_Size; --- 804,811 ---- Partition : in Partition_ID; Params_Size : in Ada.Streams.Stream_Element_Count; Result_Size : in Ada.Streams.Stream_Element_Count; ! Protocol : in Protocol_Access) ! do C_Message_Id := Message_Id; C_Partition := Partition; Params_S := Params_Size; *************** package body System.RPC is *** 812,822 **** end select; declare ! Params : aliased Params_Stream_Type (Params_S); ! Result : aliased Params_Stream_Type (Result_S); ! Header : aliased Params_Stream_Type (Header_Size); ! begin -- We reconstruct all the client context : Params and Result -- with the SAME size, then we receive Params from calling stub --- 817,827 ---- end select; declare ! Params : aliased Params_Stream_Type (Params_S); ! Result : aliased Params_Stream_Type (Result_S); ! Header : aliased Params_Stream_Type (Header_Size); + begin -- We reconstruct all the client context : Params and Result -- with the SAME size, then we receive Params from calling stub *************** package body System.RPC is *** 863,869 **** (Header'Access, Streams.Get_Stream_Size (Result'Access)); - -- Get a protocol method to comunicate with the remote -- partition and give the message size --- 868,873 ---- *************** package body System.RPC is *** 903,914 **** (C_Protocol.all, C_Partition); Streams.Deallocate (Header); - end if; Streams.Deallocate (Params); Streams.Deallocate (Result); - end; -- Enqueue into the anonymous task free list : become inactive --- 907,916 ---- *************** package body System.RPC is *** 917,925 **** end loop; ! exception when others => ! D (D_Exception, "exception in Anonymous_Task_Type body"); ! raise; end Anonymous_Task_Type; ----------------- --- 919,928 ---- end loop; ! exception ! when others => ! D (D_Exception, "exception in Anonymous_Task_Type body"); ! raise; end Anonymous_Task_Type; ----------------- *************** package body System.RPC is *** 934,948 **** Header : aliased Params_Stream_Type (Header_Size); Protocol : Protocol_Access; Anonymous : Anonymous_Task_Node_Access; - begin -- Wait the Partition_RPC_Receiver to be set accept Start; D (D_Elaborate, "Environment task elaborated"); loop - -- We receive first a fixed size message : the header -- Header = Message Id + Message Size --- 937,950 ---- Header : aliased Params_Stream_Type (Header_Size); Protocol : Protocol_Access; Anonymous : Anonymous_Task_Node_Access; + begin -- Wait the Partition_RPC_Receiver to be set accept Start; D (D_Elaborate, "Environment task elaborated"); loop -- We receive first a fixed size message : the header -- Header = Message Id + Message Size *************** package body System.RPC is *** 952,961 **** -- protocol to use to communicate with the calling partition Garlic.Initiate_Receive ! (Partition, ! Message_Size, ! Protocol, ! Garlic.Remote_Call); D (D_Communication, "Environment task - Receive protocol to talk to active partition" & Partition_ID'Image (Partition)); --- 954,963 ---- -- protocol to use to communicate with the calling partition Garlic.Initiate_Receive ! (Partition, ! Message_Size, ! Protocol, ! Garlic.Remote_Call); D (D_Communication, "Environment task - Receive protocol to talk to active partition" & Partition_ID'Image (Partition)); *************** package body System.RPC is *** 968,976 **** "Environment task - Receive Header from partition" & Partition_ID'Image (Partition)); Garlic.Receive ! (Protocol.all, ! Partition, ! Header'Access); -- Evaluate the remaining size of the message --- 970,978 ---- "Environment task - Receive Header from partition" & Partition_ID'Image (Partition)); Garlic.Receive ! (Protocol.all, ! Partition, ! Header'Access); -- Evaluate the remaining size of the message *************** package body System.RPC is *** 1001,1007 **** Dispatcher.Wake_Up (-Message_Id, Result_Size); else - -- The message was send by a calling stub : get an anonymous -- task to perform the job --- 1003,1008 ---- *************** package body System.RPC is *** 1027,1039 **** end loop; ! exception when others => ! D (D_Exception, "exception in Environment"); ! raise; end Environnement; begin - -- Set debugging information Debugging.Set_Environment_Variable ("RPC"); --- 1028,1040 ---- end loop; ! exception ! when others => ! D (D_Exception, "exception in Environment"); ! raise; end Environnement; begin -- Set debugging information Debugging.Set_Environment_Variable ("RPC"); diff -Nrc3pad gcc-3.2.3/gcc/ada/a-astaco.adb gcc-3.3/gcc/ada/a-astaco.adb *** gcc-3.2.3/gcc/ada/a-astaco.adb 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/a-astaco.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-astaco.ads gcc-3.3/gcc/ada/a-astaco.ads *** gcc-3.2.3/gcc/ada/a-astaco.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/a-astaco.ads 2002-03-14 10:58:45.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-caldel.adb gcc-3.3/gcc/ada/a-caldel.adb *** gcc-3.2.3/gcc/ada/a-caldel.adb 2001-10-02 13:51:51.000000000 +0000 --- gcc-3.3/gcc/ada/a-caldel.adb 2002-03-14 10:58:45.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- --- 6,11 ---- *************** with System.OS_Primitives; *** 41,46 **** --- 40,51 ---- with System.Soft_Links; -- Used for Timed_Delay + with System.Traces; + -- Used for Send_Trace_Info + + with System.Parameters; + -- used for Runtime_Traces + package body Ada.Calendar.Delays is package OSP renames System.OS_Primitives; *************** package body Ada.Calendar.Delays is *** 48,53 **** --- 53,60 ---- use type SSL.Timed_Delay_Call; + use System.Traces; + -- Earlier, the following operations were implemented using -- System.Time_Operations. The idea was to avoid sucking in the tasking -- packages. This did not work. Logically, we can't have it both ways. *************** package body Ada.Calendar.Delays is *** 68,75 **** procedure Delay_For (D : Duration) is begin SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay), ! OSP.Relative); end Delay_For; ----------------- --- 75,90 ---- procedure Delay_For (D : Duration) is begin + if System.Parameters.Runtime_Traces then + Send_Trace_Info (W_Delay, D); + end if; + SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay), ! OSP.Relative); ! ! if System.Parameters.Runtime_Traces then ! Send_Trace_Info (M_Delay, D); ! end if; end Delay_For; ----------------- *************** package body Ada.Calendar.Delays is *** 77,84 **** ----------------- procedure Delay_Until (T : Time) is begin ! SSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar); end Delay_Until; -------------------- --- 92,109 ---- ----------------- procedure Delay_Until (T : Time) is + D : constant Duration := To_Duration (T); + begin ! if System.Parameters.Runtime_Traces then ! Send_Trace_Info (WU_Delay, D); ! end if; ! ! SSL.Timed_Delay.all (D, OSP.Absolute_Calendar); ! ! if System.Parameters.Runtime_Traces then ! Send_Trace_Info (M_Delay, D); ! end if; end Delay_Until; -------------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-caldel.ads gcc-3.3/gcc/ada/a-caldel.ads *** gcc-3.2.3/gcc/ada/a-caldel.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/a-caldel.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-calend.adb gcc-3.3/gcc/ada/a-calend.adb *** gcc-3.2.3/gcc/ada/a-calend.adb 2002-05-04 03:27:19.000000000 +0000 --- gcc-3.3/gcc/ada/a-calend.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-calend.ads gcc-3.3/gcc/ada/a-calend.ads *** gcc-3.2.3/gcc/ada/a-calend.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/a-calend.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-chahan.adb gcc-3.3/gcc/ada/a-chahan.adb *** gcc-3.2.3/gcc/ada/a-chahan.adb 2002-05-04 03:27:19.000000000 +0000 --- gcc-3.3/gcc/ada/a-chahan.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-chahan.ads gcc-3.3/gcc/ada/a-chahan.ads *** gcc-3.2.3/gcc/ada/a-chahan.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/a-chahan.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-charac.ads gcc-3.3/gcc/ada/a-charac.ads *** gcc-3.2.3/gcc/ada/a-charac.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/a-charac.ads 2002-03-14 10:58:46.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-chlat1.ads gcc-3.3/gcc/ada/a-chlat1.ads *** gcc-3.2.3/gcc/ada/a-chlat1.ads 2002-05-07 08:22:04.000000000 +0000 --- gcc-3.3/gcc/ada/a-chlat1.ads 2002-03-14 10:58:46.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-chlat9.ads gcc-3.3/gcc/ada/a-chlat9.ads *** gcc-3.2.3/gcc/ada/a-chlat9.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/a-chlat9.ads 2002-10-28 16:19:22.000000000 +0000 *************** *** 0 **** --- 1,335 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUNTIME COMPONENTS -- + -- -- + -- A D A . C H A R A C T E R S . L A T I N _ 9 -- + -- -- + -- S p e c -- + -- -- + -- -- + -- Copyright (C) 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 modifications made to Ada.Characters.Latin_1, noted -- + -- in the text, to derive the equivalent Latin-9 package. -- + -- -- + -- GNAT is 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 definitions for Latin-9 (ISO-8859-9) analogous to + -- those defined in the standard package Ada.Characters.Latin_1 for Latin-1. + + package Ada.Characters.Latin_9 is + pragma Pure (Latin_9); + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Character := Character'Val (0); + SOH : constant Character := Character'Val (1); + STX : constant Character := Character'Val (2); + ETX : constant Character := Character'Val (3); + EOT : constant Character := Character'Val (4); + ENQ : constant Character := Character'Val (5); + ACK : constant Character := Character'Val (6); + BEL : constant Character := Character'Val (7); + BS : constant Character := Character'Val (8); + HT : constant Character := Character'Val (9); + LF : constant Character := Character'Val (10); + VT : constant Character := Character'Val (11); + FF : constant Character := Character'Val (12); + CR : constant Character := Character'Val (13); + SO : constant Character := Character'Val (14); + SI : constant Character := Character'Val (15); + + DLE : constant Character := Character'Val (16); + DC1 : constant Character := Character'Val (17); + DC2 : constant Character := Character'Val (18); + DC3 : constant Character := Character'Val (19); + DC4 : constant Character := Character'Val (20); + NAK : constant Character := Character'Val (21); + SYN : constant Character := Character'Val (22); + ETB : constant Character := Character'Val (23); + CAN : constant Character := Character'Val (24); + EM : constant Character := Character'Val (25); + SUB : constant Character := Character'Val (26); + ESC : constant Character := Character'Val (27); + FS : constant Character := Character'Val (28); + GS : constant Character := Character'Val (29); + RS : constant Character := Character'Val (30); + US : constant Character := Character'Val (31); + + -------------------------------- + -- ISO 646 Graphic Characters -- + -------------------------------- + + Space : constant Character := ' '; -- Character'Val(32) + Exclamation : constant Character := '!'; -- Character'Val(33) + Quotation : constant Character := '"'; -- Character'Val(34) + Number_Sign : constant Character := '#'; -- Character'Val(35) + Dollar_Sign : constant Character := '$'; -- Character'Val(36) + Percent_Sign : constant Character := '%'; -- Character'Val(37) + Ampersand : constant Character := '&'; -- Character'Val(38) + Apostrophe : constant Character := '''; -- Character'Val(39) + Left_Parenthesis : constant Character := '('; -- Character'Val(40) + Right_Parenthesis : constant Character := ')'; -- Character'Val(41) + Asterisk : constant Character := '*'; -- Character'Val(42) + Plus_Sign : constant Character := '+'; -- Character'Val(43) + Comma : constant Character := ','; -- Character'Val(44) + Hyphen : constant Character := '-'; -- Character'Val(45) + Minus_Sign : Character renames Hyphen; + Full_Stop : constant Character := '.'; -- Character'Val(46) + Solidus : constant Character := '/'; -- Character'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Character := ':'; -- Character'Val(58) + Semicolon : constant Character := ';'; -- Character'Val(59) + Less_Than_Sign : constant Character := '<'; -- Character'Val(60) + Equals_Sign : constant Character := '='; -- Character'Val(61) + Greater_Than_Sign : constant Character := '>'; -- Character'Val(62) + Question : constant Character := '?'; -- Character'Val(63) + + Commercial_At : constant Character := '@'; -- Character'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Character := '['; -- Character'Val (91) + Reverse_Solidus : constant Character := '\'; -- Character'Val (92) + Right_Square_Bracket : constant Character := ']'; -- Character'Val (93) + Circumflex : constant Character := '^'; -- Character'Val (94) + Low_Line : constant Character := '_'; -- Character'Val (95) + + Grave : constant Character := '`'; -- Character'Val (96) + LC_A : constant Character := 'a'; -- Character'Val (97) + LC_B : constant Character := 'b'; -- Character'Val (98) + LC_C : constant Character := 'c'; -- Character'Val (99) + LC_D : constant Character := 'd'; -- Character'Val (100) + LC_E : constant Character := 'e'; -- Character'Val (101) + LC_F : constant Character := 'f'; -- Character'Val (102) + LC_G : constant Character := 'g'; -- Character'Val (103) + LC_H : constant Character := 'h'; -- Character'Val (104) + LC_I : constant Character := 'i'; -- Character'Val (105) + LC_J : constant Character := 'j'; -- Character'Val (106) + LC_K : constant Character := 'k'; -- Character'Val (107) + LC_L : constant Character := 'l'; -- Character'Val (108) + LC_M : constant Character := 'm'; -- Character'Val (109) + LC_N : constant Character := 'n'; -- Character'Val (110) + LC_O : constant Character := 'o'; -- Character'Val (111) + LC_P : constant Character := 'p'; -- Character'Val (112) + LC_Q : constant Character := 'q'; -- Character'Val (113) + LC_R : constant Character := 'r'; -- Character'Val (114) + LC_S : constant Character := 's'; -- Character'Val (115) + LC_T : constant Character := 't'; -- Character'Val (116) + LC_U : constant Character := 'u'; -- Character'Val (117) + LC_V : constant Character := 'v'; -- Character'Val (118) + LC_W : constant Character := 'w'; -- Character'Val (119) + LC_X : constant Character := 'x'; -- Character'Val (120) + LC_Y : constant Character := 'y'; -- Character'Val (121) + LC_Z : constant Character := 'z'; -- Character'Val (122) + Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123) + Vertical_Line : constant Character := '|'; -- Character'Val (124) + Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125) + Tilde : constant Character := '~'; -- Character'Val (126) + DEL : constant Character := Character'Val (127); + + --------------------------------- + -- ISO 6429 Control Characters -- + --------------------------------- + + IS4 : Character renames FS; + IS3 : Character renames GS; + IS2 : Character renames RS; + IS1 : Character renames US; + + Reserved_128 : constant Character := Character'Val (128); + Reserved_129 : constant Character := Character'Val (129); + BPH : constant Character := Character'Val (130); + NBH : constant Character := Character'Val (131); + Reserved_132 : constant Character := Character'Val (132); + NEL : constant Character := Character'Val (133); + SSA : constant Character := Character'Val (134); + ESA : constant Character := Character'Val (135); + HTS : constant Character := Character'Val (136); + HTJ : constant Character := Character'Val (137); + VTS : constant Character := Character'Val (138); + PLD : constant Character := Character'Val (139); + PLU : constant Character := Character'Val (140); + RI : constant Character := Character'Val (141); + SS2 : constant Character := Character'Val (142); + SS3 : constant Character := Character'Val (143); + + DCS : constant Character := Character'Val (144); + PU1 : constant Character := Character'Val (145); + PU2 : constant Character := Character'Val (146); + STS : constant Character := Character'Val (147); + CCH : constant Character := Character'Val (148); + MW : constant Character := Character'Val (149); + SPA : constant Character := Character'Val (150); + EPA : constant Character := Character'Val (151); + + SOS : constant Character := Character'Val (152); + Reserved_153 : constant Character := Character'Val (153); + SCI : constant Character := Character'Val (154); + CSI : constant Character := Character'Val (155); + ST : constant Character := Character'Val (156); + OSC : constant Character := Character'Val (157); + PM : constant Character := Character'Val (158); + APC : constant Character := Character'Val (159); + + ------------------------------ + -- Other Graphic Characters -- + ------------------------------ + + -- Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Character := Character'Val (160); + NBSP : Character renames No_Break_Space; + Inverted_Exclamation : constant Character := Character'Val (161); + Cent_Sign : constant Character := Character'Val (162); + Pound_Sign : constant Character := Character'Val (163); + Euro_Sign : constant Character := Character'Val (164); + Yen_Sign : constant Character := Character'Val (165); + UC_S_Caron : constant Character := Character'Val (166); + Section_Sign : constant Character := Character'Val (167); + LC_S_Caron : constant Character := Character'Val (168); + Copyright_Sign : constant Character := Character'Val (169); + Feminine_Ordinal_Indicator : constant Character := Character'Val (170); + Left_Angle_Quotation : constant Character := Character'Val (171); + Not_Sign : constant Character := Character'Val (172); + Soft_Hyphen : constant Character := Character'Val (173); + Registered_Trade_Mark_Sign : constant Character := Character'Val (174); + Macron : constant Character := Character'Val (175); + + -- Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Character := Character'Val (176); + Ring_Above : Character renames Degree_Sign; + Plus_Minus_Sign : constant Character := Character'Val (177); + Superscript_Two : constant Character := Character'Val (178); + Superscript_Three : constant Character := Character'Val (179); + UC_Z_Caron : constant Character := Character'Val (180); + Micro_Sign : constant Character := Character'Val (181); + Pilcrow_Sign : constant Character := Character'Val (182); + Paragraph_Sign : Character renames Pilcrow_Sign; + Middle_Dot : constant Character := Character'Val (183); + LC_Z_Caron : constant Character := Character'Val (184); + Superscript_One : constant Character := Character'Val (185); + Masculine_Ordinal_Indicator : constant Character := Character'Val (186); + Right_Angle_Quotation : constant Character := Character'Val (187); + UC_Ligature_OE : constant Character := Character'Val (188); + LC_Ligature_OE : constant Character := Character'Val (189); + UC_Y_Diaeresis : constant Character := Character'Val (190); + Inverted_Question : constant Character := Character'Val (191); + + -- Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Character := Character'Val (192); + UC_A_Acute : constant Character := Character'Val (193); + UC_A_Circumflex : constant Character := Character'Val (194); + UC_A_Tilde : constant Character := Character'Val (195); + UC_A_Diaeresis : constant Character := Character'Val (196); + UC_A_Ring : constant Character := Character'Val (197); + UC_AE_Diphthong : constant Character := Character'Val (198); + UC_C_Cedilla : constant Character := Character'Val (199); + UC_E_Grave : constant Character := Character'Val (200); + UC_E_Acute : constant Character := Character'Val (201); + UC_E_Circumflex : constant Character := Character'Val (202); + UC_E_Diaeresis : constant Character := Character'Val (203); + UC_I_Grave : constant Character := Character'Val (204); + UC_I_Acute : constant Character := Character'Val (205); + UC_I_Circumflex : constant Character := Character'Val (206); + UC_I_Diaeresis : constant Character := Character'Val (207); + + -- Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Character := Character'Val (208); + UC_N_Tilde : constant Character := Character'Val (209); + UC_O_Grave : constant Character := Character'Val (210); + UC_O_Acute : constant Character := Character'Val (211); + UC_O_Circumflex : constant Character := Character'Val (212); + UC_O_Tilde : constant Character := Character'Val (213); + UC_O_Diaeresis : constant Character := Character'Val (214); + Multiplication_Sign : constant Character := Character'Val (215); + UC_O_Oblique_Stroke : constant Character := Character'Val (216); + UC_U_Grave : constant Character := Character'Val (217); + UC_U_Acute : constant Character := Character'Val (218); + UC_U_Circumflex : constant Character := Character'Val (219); + UC_U_Diaeresis : constant Character := Character'Val (220); + UC_Y_Acute : constant Character := Character'Val (221); + UC_Icelandic_Thorn : constant Character := Character'Val (222); + LC_German_Sharp_S : constant Character := Character'Val (223); + + -- Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Character := Character'Val (224); + LC_A_Acute : constant Character := Character'Val (225); + LC_A_Circumflex : constant Character := Character'Val (226); + LC_A_Tilde : constant Character := Character'Val (227); + LC_A_Diaeresis : constant Character := Character'Val (228); + LC_A_Ring : constant Character := Character'Val (229); + LC_AE_Diphthong : constant Character := Character'Val (230); + LC_C_Cedilla : constant Character := Character'Val (231); + LC_E_Grave : constant Character := Character'Val (232); + LC_E_Acute : constant Character := Character'Val (233); + LC_E_Circumflex : constant Character := Character'Val (234); + LC_E_Diaeresis : constant Character := Character'Val (235); + LC_I_Grave : constant Character := Character'Val (236); + LC_I_Acute : constant Character := Character'Val (237); + LC_I_Circumflex : constant Character := Character'Val (238); + LC_I_Diaeresis : constant Character := Character'Val (239); + + -- Character positions 240 (16#F0#) .. 255 (16#FF) + LC_Icelandic_Eth : constant Character := Character'Val (240); + LC_N_Tilde : constant Character := Character'Val (241); + LC_O_Grave : constant Character := Character'Val (242); + LC_O_Acute : constant Character := Character'Val (243); + LC_O_Circumflex : constant Character := Character'Val (244); + LC_O_Tilde : constant Character := Character'Val (245); + LC_O_Diaeresis : constant Character := Character'Val (246); + Division_Sign : constant Character := Character'Val (247); + LC_O_Oblique_Stroke : constant Character := Character'Val (248); + LC_U_Grave : constant Character := Character'Val (249); + LC_U_Acute : constant Character := Character'Val (250); + LC_U_Circumflex : constant Character := Character'Val (251); + LC_U_Diaeresis : constant Character := Character'Val (252); + LC_Y_Acute : constant Character := Character'Val (253); + LC_Icelandic_Thorn : constant Character := Character'Val (254); + LC_Y_Diaeresis : constant Character := Character'Val (255); + + ------------------------------------------------ + -- Summary of Changes from Latin-1 => Latin-9 -- + ------------------------------------------------ + + -- 164 Currency => Euro_Sign + -- 166 Broken_Bar => UC_S_Caron + -- 168 Diaeresis => LC_S_Caron + -- 180 Acute => UC_Z_Caron + -- 184 Cedilla => LC_Z_Caron + -- 188 Fraction_One_Quarter => UC_Ligature_OE + -- 189 Fraction_One_Half => LC_Ligature_OE + -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis + + end Ada.Characters.Latin_9; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-colien.adb gcc-3.3/gcc/ada/a-colien.adb *** gcc-3.2.3/gcc/ada/a-colien.adb 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-colien.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-colien.ads gcc-3.3/gcc/ada/a-colien.ads *** gcc-3.2.3/gcc/ada/a-colien.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-colien.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-colire.adb gcc-3.3/gcc/ada/a-colire.adb *** gcc-3.2.3/gcc/ada/a-colire.adb 2002-05-04 03:27:20.000000000 +0000 --- gcc-3.3/gcc/ada/a-colire.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-colire.ads gcc-3.3/gcc/ada/a-colire.ads *** gcc-3.2.3/gcc/ada/a-colire.ads 2002-05-04 03:27:20.000000000 +0000 --- gcc-3.3/gcc/ada/a-colire.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-comlin.adb gcc-3.3/gcc/ada/a-comlin.adb *** gcc-3.2.3/gcc/ada/a-comlin.adb 2002-05-04 03:27:20.000000000 +0000 --- gcc-3.3/gcc/ada/a-comlin.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-comlin.ads gcc-3.3/gcc/ada/a-comlin.ads *** gcc-3.2.3/gcc/ada/a-comlin.ads 2002-05-04 03:27:20.000000000 +0000 --- gcc-3.3/gcc/ada/a-comlin.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** pragma Preelaborate (Command_Line); *** 71,83 **** procedure Set_Exit_Status (Code : Exit_Status); ! private Success : constant Exit_Status := 0; Failure : constant Exit_Status := 1; -- The following locations support the operation of the package ! -- Ada.Command_Line_Remove, whih provides facilities for logically -- removing arguments from the command line. If one of the remove -- procedures is called in this unit, then Remove_Args/Remove_Count -- are set to indicate which arguments are removed. If no such calls --- 70,117 ---- procedure Set_Exit_Status (Code : Exit_Status); ! ------------------------------------ ! -- Note on Interface Requirements -- ! ------------------------------------ ! ! -- If the main program is in Ada, this package works as specified without ! -- any other work than the normal steps of WITH'ing the package and then ! -- calling the desired routines. ! ! -- If the main program is not in Ada, then the information must be made ! -- available for this package to work correctly. In particular, it is ! -- required that the global variable "gnat_argc" contain the number of ! -- arguments, and that the global variable "gnat_argv" points to an ! -- array of null-terminated strings, the first entry being the command ! -- name, and the remaining entries being the command arguments. ! ! -- These correspond to the normal argc/argv variables passed to a C ! -- main program, and the following is an example of a complete C main ! -- program that stores the required information: + -- main(int argc, char **argv, char **envp) + -- { + -- extern int gnat_argc; + -- extern char **gnat_argv; + -- extern char **gnat_envp; + -- gnat_argc = argc; + -- gnat_argv = argv; + -- gnat_envp = envp; + + -- adainit(); + -- adamain(); + -- adafinal(); + -- } + + -- The assignment statements ensure that the necessary information is + -- available for finding the command name and command line arguments. + + private Success : constant Exit_Status := 0; Failure : constant Exit_Status := 1; -- The following locations support the operation of the package ! -- Ada.Command_Line.Remove, whih provides facilities for logically -- removing arguments from the command line. If one of the remove -- procedures is called in this unit, then Remove_Args/Remove_Count -- are set to indicate which arguments are removed. If no such calls diff -Nrc3pad gcc-3.2.3/gcc/ada/a-cwila1.ads gcc-3.3/gcc/ada/a-cwila1.ads *** gcc-3.2.3/gcc/ada/a-cwila1.ads 2002-05-04 03:27:20.000000000 +0000 --- gcc-3.3/gcc/ada/a-cwila1.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-cwila9.ads gcc-3.3/gcc/ada/a-cwila9.ads *** gcc-3.2.3/gcc/ada/a-cwila9.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/a-cwila9.ads 2002-10-28 16:19:22.000000000 +0000 *************** *** 0 **** --- 1,337 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUNTIME COMPONENTS -- + -- -- + -- A D A . C H A R A C T E R S . W I D E _ L A T I N _ 9 -- + -- -- + -- 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- -- + -- 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 definitions analogous to those in the GNAT + -- package Ada.Characters.Latin_9 except that the type of the constants + -- is Wide_Character instead of Character. The provision of this package + -- is in accordance with the implementation permission in RM (A.3.3(27)). + + package Ada.Characters.Wide_Latin_9 is + pragma Pure (Wide_Latin_9); + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Wide_Character := Wide_Character'Val (0); + SOH : constant Wide_Character := Wide_Character'Val (1); + STX : constant Wide_Character := Wide_Character'Val (2); + ETX : constant Wide_Character := Wide_Character'Val (3); + EOT : constant Wide_Character := Wide_Character'Val (4); + ENQ : constant Wide_Character := Wide_Character'Val (5); + ACK : constant Wide_Character := Wide_Character'Val (6); + BEL : constant Wide_Character := Wide_Character'Val (7); + BS : constant Wide_Character := Wide_Character'Val (8); + HT : constant Wide_Character := Wide_Character'Val (9); + LF : constant Wide_Character := Wide_Character'Val (10); + VT : constant Wide_Character := Wide_Character'Val (11); + FF : constant Wide_Character := Wide_Character'Val (12); + CR : constant Wide_Character := Wide_Character'Val (13); + SO : constant Wide_Character := Wide_Character'Val (14); + SI : constant Wide_Character := Wide_Character'Val (15); + + DLE : constant Wide_Character := Wide_Character'Val (16); + DC1 : constant Wide_Character := Wide_Character'Val (17); + DC2 : constant Wide_Character := Wide_Character'Val (18); + DC3 : constant Wide_Character := Wide_Character'Val (19); + DC4 : constant Wide_Character := Wide_Character'Val (20); + NAK : constant Wide_Character := Wide_Character'Val (21); + SYN : constant Wide_Character := Wide_Character'Val (22); + ETB : constant Wide_Character := Wide_Character'Val (23); + CAN : constant Wide_Character := Wide_Character'Val (24); + EM : constant Wide_Character := Wide_Character'Val (25); + SUB : constant Wide_Character := Wide_Character'Val (26); + ESC : constant Wide_Character := Wide_Character'Val (27); + FS : constant Wide_Character := Wide_Character'Val (28); + GS : constant Wide_Character := Wide_Character'Val (29); + RS : constant Wide_Character := Wide_Character'Val (30); + US : constant Wide_Character := Wide_Character'Val (31); + + ------------------------------------- + -- ISO 646 Graphic Wide_Characters -- + ------------------------------------- + + Space : constant Wide_Character := ' '; -- WC'Val(32) + Exclamation : constant Wide_Character := '!'; -- WC'Val(33) + Quotation : constant Wide_Character := '"'; -- WC'Val(34) + Number_Sign : constant Wide_Character := '#'; -- WC'Val(35) + Dollar_Sign : constant Wide_Character := '$'; -- WC'Val(36) + Percent_Sign : constant Wide_Character := '%'; -- WC'Val(37) + Ampersand : constant Wide_Character := '&'; -- WC'Val(38) + Apostrophe : constant Wide_Character := '''; -- WC'Val(39) + Left_Parenthesis : constant Wide_Character := '('; -- WC'Val(40) + Right_Parenthesis : constant Wide_Character := ')'; -- WC'Val(41) + Asterisk : constant Wide_Character := '*'; -- WC'Val(42) + Plus_Sign : constant Wide_Character := '+'; -- WC'Val(43) + Comma : constant Wide_Character := ','; -- WC'Val(44) + Hyphen : constant Wide_Character := '-'; -- WC'Val(45) + Minus_Sign : Wide_Character renames Hyphen; + Full_Stop : constant Wide_Character := '.'; -- WC'Val(46) + Solidus : constant Wide_Character := '/'; -- WC'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Wide_Character := ':'; -- WC'Val(58) + Semicolon : constant Wide_Character := ';'; -- WC'Val(59) + Less_Than_Sign : constant Wide_Character := '<'; -- WC'Val(60) + Equals_Sign : constant Wide_Character := '='; -- WC'Val(61) + Greater_Than_Sign : constant Wide_Character := '>'; -- WC'Val(62) + Question : constant Wide_Character := '?'; -- WC'Val(63) + + Commercial_At : constant Wide_Character := '@'; -- WC'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Wide_Character := '['; -- WC'Val (91) + Reverse_Solidus : constant Wide_Character := '\'; -- WC'Val (92) + Right_Square_Bracket : constant Wide_Character := ']'; -- WC'Val (93) + Circumflex : constant Wide_Character := '^'; -- WC'Val (94) + Low_Line : constant Wide_Character := '_'; -- WC'Val (95) + + Grave : constant Wide_Character := '`'; -- WC'Val (96) + LC_A : constant Wide_Character := 'a'; -- WC'Val (97) + LC_B : constant Wide_Character := 'b'; -- WC'Val (98) + LC_C : constant Wide_Character := 'c'; -- WC'Val (99) + LC_D : constant Wide_Character := 'd'; -- WC'Val (100) + LC_E : constant Wide_Character := 'e'; -- WC'Val (101) + LC_F : constant Wide_Character := 'f'; -- WC'Val (102) + LC_G : constant Wide_Character := 'g'; -- WC'Val (103) + LC_H : constant Wide_Character := 'h'; -- WC'Val (104) + LC_I : constant Wide_Character := 'i'; -- WC'Val (105) + LC_J : constant Wide_Character := 'j'; -- WC'Val (106) + LC_K : constant Wide_Character := 'k'; -- WC'Val (107) + LC_L : constant Wide_Character := 'l'; -- WC'Val (108) + LC_M : constant Wide_Character := 'm'; -- WC'Val (109) + LC_N : constant Wide_Character := 'n'; -- WC'Val (110) + LC_O : constant Wide_Character := 'o'; -- WC'Val (111) + LC_P : constant Wide_Character := 'p'; -- WC'Val (112) + LC_Q : constant Wide_Character := 'q'; -- WC'Val (113) + LC_R : constant Wide_Character := 'r'; -- WC'Val (114) + LC_S : constant Wide_Character := 's'; -- WC'Val (115) + LC_T : constant Wide_Character := 't'; -- WC'Val (116) + LC_U : constant Wide_Character := 'u'; -- WC'Val (117) + LC_V : constant Wide_Character := 'v'; -- WC'Val (118) + LC_W : constant Wide_Character := 'w'; -- WC'Val (119) + LC_X : constant Wide_Character := 'x'; -- WC'Val (120) + LC_Y : constant Wide_Character := 'y'; -- WC'Val (121) + LC_Z : constant Wide_Character := 'z'; -- WC'Val (122) + Left_Curly_Bracket : constant Wide_Character := '{'; -- WC'Val (123) + Vertical_Line : constant Wide_Character := '|'; -- WC'Val (124) + Right_Curly_Bracket : constant Wide_Character := '}'; -- WC'Val (125) + Tilde : constant Wide_Character := '~'; -- WC'Val (126) + DEL : constant Wide_Character := Wide_Character'Val (127); + + -------------------------------------- + -- ISO 6429 Control Wide_Characters -- + -------------------------------------- + + IS4 : Wide_Character renames FS; + IS3 : Wide_Character renames GS; + IS2 : Wide_Character renames RS; + IS1 : Wide_Character renames US; + + Reserved_128 : constant Wide_Character := Wide_Character'Val (128); + Reserved_129 : constant Wide_Character := Wide_Character'Val (129); + BPH : constant Wide_Character := Wide_Character'Val (130); + NBH : constant Wide_Character := Wide_Character'Val (131); + Reserved_132 : constant Wide_Character := Wide_Character'Val (132); + NEL : constant Wide_Character := Wide_Character'Val (133); + SSA : constant Wide_Character := Wide_Character'Val (134); + ESA : constant Wide_Character := Wide_Character'Val (135); + HTS : constant Wide_Character := Wide_Character'Val (136); + HTJ : constant Wide_Character := Wide_Character'Val (137); + VTS : constant Wide_Character := Wide_Character'Val (138); + PLD : constant Wide_Character := Wide_Character'Val (139); + PLU : constant Wide_Character := Wide_Character'Val (140); + RI : constant Wide_Character := Wide_Character'Val (141); + SS2 : constant Wide_Character := Wide_Character'Val (142); + SS3 : constant Wide_Character := Wide_Character'Val (143); + + DCS : constant Wide_Character := Wide_Character'Val (144); + PU1 : constant Wide_Character := Wide_Character'Val (145); + PU2 : constant Wide_Character := Wide_Character'Val (146); + STS : constant Wide_Character := Wide_Character'Val (147); + CCH : constant Wide_Character := Wide_Character'Val (148); + MW : constant Wide_Character := Wide_Character'Val (149); + SPA : constant Wide_Character := Wide_Character'Val (150); + EPA : constant Wide_Character := Wide_Character'Val (151); + + SOS : constant Wide_Character := Wide_Character'Val (152); + Reserved_153 : constant Wide_Character := Wide_Character'Val (153); + SCI : constant Wide_Character := Wide_Character'Val (154); + CSI : constant Wide_Character := Wide_Character'Val (155); + ST : constant Wide_Character := Wide_Character'Val (156); + OSC : constant Wide_Character := Wide_Character'Val (157); + PM : constant Wide_Character := Wide_Character'Val (158); + APC : constant Wide_Character := Wide_Character'Val (159); + + ----------------------------------- + -- Other Graphic Wide_Characters -- + ----------------------------------- + + -- Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Wide_Character := Wide_Character'Val (160); + NBSP : Wide_Character renames No_Break_Space; + Inverted_Exclamation : constant Wide_Character := Wide_Character'Val (161); + Cent_Sign : constant Wide_Character := Wide_Character'Val (162); + Pound_Sign : constant Wide_Character := Wide_Character'Val (163); + Euro_Sign : constant Wide_Character := Wide_Character'Val (164); + Yen_Sign : constant Wide_Character := Wide_Character'Val (165); + UC_S_Caron : constant Wide_Character := Wide_Character'Val (166); + Section_Sign : constant Wide_Character := Wide_Character'Val (167); + LC_S_Caron : constant Wide_Character := Wide_Character'Val (168); + Copyright_Sign : constant Wide_Character := Wide_Character'Val (169); + Feminine_Ordinal_Indicator + : constant Wide_Character := Wide_Character'Val (170); + Left_Angle_Quotation : constant Wide_Character := Wide_Character'Val (171); + Not_Sign : constant Wide_Character := Wide_Character'Val (172); + Soft_Hyphen : constant Wide_Character := Wide_Character'Val (173); + Registered_Trade_Mark_Sign + : constant Wide_Character := Wide_Character'Val (174); + Macron : constant Wide_Character := Wide_Character'Val (175); + + -- Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Wide_Character := Wide_Character'Val (176); + Ring_Above : Wide_Character renames Degree_Sign; + Plus_Minus_Sign : constant Wide_Character := Wide_Character'Val (177); + Superscript_Two : constant Wide_Character := Wide_Character'Val (178); + Superscript_Three : constant Wide_Character := Wide_Character'Val (179); + UC_Z_Caron : constant Wide_Character := Wide_Character'Val (180); + Micro_Sign : constant Wide_Character := Wide_Character'Val (181); + Pilcrow_Sign : constant Wide_Character := Wide_Character'Val (182); + Paragraph_Sign : Wide_Character renames Pilcrow_Sign; + Middle_Dot : constant Wide_Character := Wide_Character'Val (183); + LC_Z_Caron : constant Wide_Character := Wide_Character'Val (184); + Superscript_One : constant Wide_Character := Wide_Character'Val (185); + Masculine_Ordinal_Indicator + : constant Wide_Character := Wide_Character'Val (186); + Right_Angle_Quotation + : constant Wide_Character := Wide_Character'Val (187); + UC_Ligature_OE : constant Wide_Character := Wide_Character'Val (188); + LC_Ligature_OE : constant Wide_Character := Wide_Character'Val (189); + UC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (190); + Inverted_Question : constant Wide_Character := Wide_Character'Val (191); + + -- Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Wide_Character := Wide_Character'Val (192); + UC_A_Acute : constant Wide_Character := Wide_Character'Val (193); + UC_A_Circumflex : constant Wide_Character := Wide_Character'Val (194); + UC_A_Tilde : constant Wide_Character := Wide_Character'Val (195); + UC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (196); + UC_A_Ring : constant Wide_Character := Wide_Character'Val (197); + UC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (198); + UC_C_Cedilla : constant Wide_Character := Wide_Character'Val (199); + UC_E_Grave : constant Wide_Character := Wide_Character'Val (200); + UC_E_Acute : constant Wide_Character := Wide_Character'Val (201); + UC_E_Circumflex : constant Wide_Character := Wide_Character'Val (202); + UC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (203); + UC_I_Grave : constant Wide_Character := Wide_Character'Val (204); + UC_I_Acute : constant Wide_Character := Wide_Character'Val (205); + UC_I_Circumflex : constant Wide_Character := Wide_Character'Val (206); + UC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (207); + + -- Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (208); + UC_N_Tilde : constant Wide_Character := Wide_Character'Val (209); + UC_O_Grave : constant Wide_Character := Wide_Character'Val (210); + UC_O_Acute : constant Wide_Character := Wide_Character'Val (211); + UC_O_Circumflex : constant Wide_Character := Wide_Character'Val (212); + UC_O_Tilde : constant Wide_Character := Wide_Character'Val (213); + UC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (214); + Multiplication_Sign : constant Wide_Character := Wide_Character'Val (215); + UC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (216); + UC_U_Grave : constant Wide_Character := Wide_Character'Val (217); + UC_U_Acute : constant Wide_Character := Wide_Character'Val (218); + UC_U_Circumflex : constant Wide_Character := Wide_Character'Val (219); + UC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (220); + UC_Y_Acute : constant Wide_Character := Wide_Character'Val (221); + UC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (222); + LC_German_Sharp_S : constant Wide_Character := Wide_Character'Val (223); + + -- Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Wide_Character := Wide_Character'Val (224); + LC_A_Acute : constant Wide_Character := Wide_Character'Val (225); + LC_A_Circumflex : constant Wide_Character := Wide_Character'Val (226); + LC_A_Tilde : constant Wide_Character := Wide_Character'Val (227); + LC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (228); + LC_A_Ring : constant Wide_Character := Wide_Character'Val (229); + LC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (230); + LC_C_Cedilla : constant Wide_Character := Wide_Character'Val (231); + LC_E_Grave : constant Wide_Character := Wide_Character'Val (232); + LC_E_Acute : constant Wide_Character := Wide_Character'Val (233); + LC_E_Circumflex : constant Wide_Character := Wide_Character'Val (234); + LC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (235); + LC_I_Grave : constant Wide_Character := Wide_Character'Val (236); + LC_I_Acute : constant Wide_Character := Wide_Character'Val (237); + LC_I_Circumflex : constant Wide_Character := Wide_Character'Val (238); + LC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (239); + + -- Wide_Character positions 240 (16#F0#) .. 255 (16#FF) + + LC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (240); + LC_N_Tilde : constant Wide_Character := Wide_Character'Val (241); + LC_O_Grave : constant Wide_Character := Wide_Character'Val (242); + LC_O_Acute : constant Wide_Character := Wide_Character'Val (243); + LC_O_Circumflex : constant Wide_Character := Wide_Character'Val (244); + LC_O_Tilde : constant Wide_Character := Wide_Character'Val (245); + LC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (246); + Division_Sign : constant Wide_Character := Wide_Character'Val (247); + LC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (248); + LC_U_Grave : constant Wide_Character := Wide_Character'Val (249); + LC_U_Acute : constant Wide_Character := Wide_Character'Val (250); + LC_U_Circumflex : constant Wide_Character := Wide_Character'Val (251); + LC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (252); + LC_Y_Acute : constant Wide_Character := Wide_Character'Val (253); + LC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (254); + LC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (255); + + ------------------------------------------------ + -- Summary of Changes from Latin-1 => Latin-9 -- + ------------------------------------------------ + + -- 164 Currency => Euro_Sign + -- 166 Broken_Bar => UC_S_Caron + -- 168 Diaeresis => LC_S_Caron + -- 180 Acute => UC_Z_Caron + -- 184 Cedilla => LC_Z_Caron + -- 188 Fraction_One_Quarter => UC_Ligature_OE + -- 189 Fraction_One_Half => LC_Ligature_OE + -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis + + end Ada.Characters.Wide_Latin_9; diff -Nrc3pad gcc-3.2.3/gcc/ada/ada.ads gcc-3.3/gcc/ada/ada.ads *** gcc-3.2.3/gcc/ada/ada.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/ada.ads 2002-03-14 10:59:01.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/adadecode.c gcc-3.3/gcc/ada/adadecode.c *** gcc-3.2.3/gcc/ada/adadecode.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/adadecode.c 2002-10-23 08:04:17.000000000 +0000 *************** *** 0 **** --- 1,319 ---- + /**************************************************************************** + * * + * 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- * + * 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 IN_GCC + #include "config.h" + #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; + + /* 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); + + verbose_info = 1; + } + + /* 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; + } + + /* 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); + + return nlen > slen && strncmp (name + nlen - slen, suffix, slen) == 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 + below. Right now only objects and routines are handled. There is no support + for Ada types. + + CODED_NAME is the encoded entity name. + + ADA_NAME is a pointer to a buffer, it will receive the Ada name. A safe + size for this buffer is: strlen (coded_name) * 2 + 60. (60 is for the + 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 ). + + Coded name Ada name verbose info + --------------------------------------------------------------------- + _ada_xyz xyz library level + x__y__z x.y.z + x__yTKB x.y task body + x__yB x.y task body + x__yX x.y body nested + x__yXb x.y body nested + xTK__y x.y in task + x__y$2 x.y overloaded + x__y__3 x.y overloaded + x__Oabs "abs" + x__Oand "and" + x__Omod "mod" + x__Onot "not" + x__Oor "or" + x__Orem "rem" + x__Oxor "xor" + x__Oeq "=" + x__One "/=" + x__Olt "<" + x__Ole "<=" + x__Ogt ">" + x__Oge ">=" + x__Oadd "+" + x__Osubtract "-" + x__Oconcat "&" + x__Omultiply "*" + x__Odivide "/" + 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; + int task_body = 0; + 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")) + { + ada_name[strlen (ada_name) - 3] = '\0'; + task_body = 1; + } + + if (has_suffix (ada_name, "B")) + { + ada_name[strlen (ada_name) - 1] = '\0'; + task_body = 1; + } + + /* Check for body-nested entity: X[bn] */ + if (has_suffix (ada_name, "X")) + { + ada_name[strlen (ada_name) - 1] = '\0'; + body_nested = 1; + } + + if (has_suffix (ada_name, "Xb")) + { + ada_name[strlen (ada_name) - 2] = '\0'; + body_nested = 1; + } + + if (has_suffix (ada_name, "Xn")) + { + ada_name[strlen (ada_name) - 2] = '\0'; + body_nested = 1; + } + + /* Change instance of TK__ (object declared inside a task) to __. */ + { + char *tktoken; + + while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL) + { + strcpy (tktoken, tktoken + 2); + in_task = 1; + } + } + + /* Check for overloading: name terminated by $nn or __nn. */ + { + int len = strlen (ada_name); + 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. */ + if (ada_name[len - 1 - n_digits] == '$') + { + ada_name[len - 1 - n_digits] = '\0'; + overloaded = 1; + } + else if (ada_name[len - 1 - n_digits] == '_' + && ada_name[len - 1 - n_digits - 1] == '_') + { + ada_name[len - 1 - n_digits - 1] = '\0'; + overloaded = 1; + } + } + + /* Change all "__" to ".". */ + { + int len = strlen (ada_name); + int k = 0; + + while (k < len) + { + if (ada_name[k] == '_' && ada_name[k+1] == '_') + { + ada_name[k] = '.'; + strcpy (ada_name + k + 1, ada_name + k + 2); + len = len - 1; + } + k++; + } + } + + /* Checks for operator name. */ + { + const char *trans_table[][2] + = {{"Oabs", "\"abs\""}, {"Oand", "\"and\""}, {"Omod", "\"mod\""}, + {"Onot", "\"not\""}, {"Oor", "\"or\""}, {"Orem", "\"rem\""}, + {"Oxor", "\"xor\""}, {"Oeq", "\"=\""}, {"One", "\"/=\""}, + {"Olt", "\"<\""}, {"Ole", "\"<=\""}, {"Ogt", "\">\""}, + {"Oge", "\">=\""}, {"Oadd", "\"+\""}, {"Osubtract", "\"-\""}, + {"Oconcat", "\"&\""}, {"Omultiply", "\"*\""}, {"Odivide", "\"/\""}, + {"Oexpon", "\"**\""}, {NULL, NULL} }; + int k = 0; + + while (1) + { + char *optoken; + + if ((optoken = (char *) strstr (ada_name, trans_table[k][0])) != NULL) + { + int codedlen = strlen (trans_table[k][0]); + int oplen = strlen (trans_table[k][1]); + + if (codedlen > oplen) + /* We shrink the space. */ + strcpy (optoken, optoken + codedlen - oplen); + else if (oplen > codedlen) + { + /* We need more space. */ + int len = strlen (ada_name); + int space = oplen - codedlen; + int num_to_move = &ada_name[len] - optoken; + int t; + + for (t = 0; t < num_to_move; t++) + ada_name[len + space - t - 1] = ada_name[len - t - 1]; + } + + /* Write symbol in the space. */ + strncpy (optoken, trans_table[k][1], oplen); + } + else + k++; + + /* Check for table's ending. */ + if (trans_table[k][0] == NULL) + break; + } + } + + /* If verbose mode is on, we add some information to the Ada name. */ + if (verbose) + { + if (overloaded) + add_verbose ("overloaded", ada_name); + + if (lib_subprog) + add_verbose ("library level", ada_name); + + if (body_nested) + add_verbose ("body nested", ada_name); + + if (in_task) + add_verbose ("in task", ada_name); + + if (task_body) + add_verbose ("task body", ada_name); + + if (verbose_info == 1) + strcat (ada_name, ")"); + } + } + + char * + ada_demangle (coded_name) + const char *coded_name; + { + char ada_name[2048]; + + __gnat_decode (coded_name, ada_name, 0); + return xstrdup (ada_name); + } diff -Nrc3pad gcc-3.2.3/gcc/ada/adadecode.h gcc-3.3/gcc/ada/adadecode.h *** gcc-3.2.3/gcc/ada/adadecode.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/adadecode.h 2002-10-23 08:04:17.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + /**************************************************************************** + * * + * 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- * + * 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. * + * * + ****************************************************************************/ + + /* 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 + below. Right now only objects and routines are handled. There is no support + for Ada types. + + CODED_NAME is the encoded entity name. + ADA_NAME is a pointer to a buffer, it will receive the Ada name. A safe + size for this buffer is: strlen (coded_name) * 2 + 60. (60 is for the + 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 *)); diff -Nrc3pad gcc-3.2.3/gcc/ada/adafinal.c gcc-3.3/gcc/ada/adafinal.c *** gcc-3.2.3/gcc/ada/adafinal.c 2003-01-28 22:28:24.000000000 +0000 --- gcc-3.3/gcc/ada/adafinal.c 2003-01-29 22:37:55.000000000 +0000 *************** *** 4,10 **** * * * A D A F I N A L * * * - * $Revision: 1.1.2.1 $ * * * C Implementation File * * * --- 4,9 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/ada.h gcc-3.3/gcc/ada/ada.h *** gcc-3.2.3/gcc/ada/ada.h 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/ada.h 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** * * * C Header File * * * - * $Revision: 1.1.16.1 $ * * ! * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * --- 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- * *************** *** 35,40 **** --- 34,42 ---- /* This file contains some standard macros for performing Ada-like operations. These are used to aid in the translation of other headers. */ + #ifndef GCC_ADA_H + #define GCC_ADA_H + /* Inlined functions in header are preceded by INLINE, which is normally set to extern inline for GCC, but may be set to static for use in standard ANSI-C. */ *************** *** 63,76 **** effect is to compile a typedef defining the subtype as a synonym for the type, together with two constants defining the end points. */ ! #define SUBTYPE(SUBTYPE,TYPE,FIRST,LAST) \ ! typedef TYPE SUBTYPE; \ ! static const SUBTYPE CAT (SUBTYPE,__First) = FIRST; \ ! static const SUBTYPE CAT (SUBTYPE,__Last) = LAST; /* The following definitions provide the equivalent of the Ada IN and NOT IN operators, assuming that the subtype involved has been defined using the SUBTYPE macro defined above. */ #define IN(VALUE,SUBTYPE) \ ! (((VALUE) >= CAT (SUBTYPE,__First)) && ((VALUE) <= CAT (SUBTYPE,__Last))) --- 65,81 ---- effect is to compile a typedef defining the subtype as a synonym for the type, together with two constants defining the end points. */ ! #define SUBTYPE(SUBTYPE,TYPE,FIRST,LAST) \ ! typedef TYPE SUBTYPE; \ ! enum { CAT (SUBTYPE,__First) = FIRST, \ ! CAT (SUBTYPE,__Last) = LAST }; /* The following definitions provide the equivalent of the Ada IN and NOT IN operators, assuming that the subtype involved has been defined using the SUBTYPE macro defined above. */ #define IN(VALUE,SUBTYPE) \ ! (((VALUE) >= (SUBTYPE) CAT (SUBTYPE,__First)) && \ ! ((VALUE) <= (SUBTYPE) CAT (SUBTYPE,__Last))) ! ! #endif diff -Nrc3pad gcc-3.2.3/gcc/ada/adaint.c gcc-3.3/gcc/ada/adaint.c *** gcc-3.2.3/gcc/ada/adaint.c 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/adaint.c 2002-11-18 14:39:46.000000000 +0000 *************** *** 4,14 **** * * * A D A I N T * * * - * $Revision: 1.7.2.2 $ * * * 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- * --- 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- * *************** *** 32,47 **** * * ****************************************************************************/ ! /* This file contains those routines named by Import pragmas in packages */ ! /* in the GNAT hierarchy (especially GNAT.OS_Lib) and in package Osint. */ ! /* Many of the subprograms in OS_Lib import standard library calls */ ! /* directly. This file contains all other routines. */ #ifdef __vxworks ! /* No need to redefine exit here */ ! #ifdef exit #undef exit ! #endif /* We want to use the POSIX variants of include files. */ #define POSIX #include "vxWorks.h" --- 31,46 ---- * * ****************************************************************************/ ! /* This file contains those routines named by Import pragmas in ! packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in ! package Osint. Many of the subprograms in OS_Lib import standard ! library calls directly. This file contains all other routines. */ #ifdef __vxworks ! ! /* No need to redefine exit here. */ #undef exit ! /* We want to use the POSIX variants of include files. */ #define POSIX #include "vxWorks.h" *************** *** 59,66 **** #include #include ! /* We don't have libiberty, so us malloc. */ #define xmalloc(S) malloc (S) #else #include "config.h" #include "system.h" --- 58,66 ---- #include #include ! /* We don't have libiberty, so use malloc. */ #define xmalloc(S) malloc (S) + #define xrealloc(V,S) realloc (V,S) #else #include "config.h" #include "system.h" *************** *** 70,76 **** #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) #elif defined (VMS) ! /* Header files and definitions for __gnat_set_file_time_name. */ #include #include --- 70,76 ---- #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) #elif defined (VMS) ! /* Header files and definitions for __gnat_set_file_time_name. */ #include #include *************** *** 82,88 **** #include #include ! /* use native 64-bit arithmetic */ #define unix_time_to_vms(X,Y) \ { unsigned long long reftime, tmptime = (X); \ $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \ --- 82,88 ---- #include #include ! /* Use native 64-bit arithmetic. */ #define unix_time_to_vms(X,Y) \ { unsigned long long reftime, tmptime = (X); \ $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \ *************** static char *tryfile; *** 109,118 **** struct vstring { short length; ! char string [NAM$C_MAXRSS+1]; }; - #else #include #endif --- 109,117 ---- struct vstring { short length; ! char string[NAM$C_MAXRSS+1]; }; #else #include #endif *************** char __gnat_path_separator = PATH_SEPARA *** 192,203 **** ??? This should be part of a GNAT host-specific compiler file instead of being included in all user applications ! as well. This is only a temporary work-around for 3.11b. */ #ifndef GNAT_LIBRARY_TEMPLATE ! #if defined(__EMX__) #define GNAT_LIBRARY_TEMPLATE "*.a" ! #elif defined(VMS) #define GNAT_LIBRARY_TEMPLATE "*.olb" #else #define GNAT_LIBRARY_TEMPLATE "lib*.a" --- 191,202 ---- ??? This should be part of a GNAT host-specific compiler file instead of being included in all user applications ! as well. This is only a temporary work-around for 3.11b. */ #ifndef GNAT_LIBRARY_TEMPLATE ! #if defined (__EMX__) #define GNAT_LIBRARY_TEMPLATE "*.a" ! #elif defined (VMS) #define GNAT_LIBRARY_TEMPLATE "*.olb" #else #define GNAT_LIBRARY_TEMPLATE "lib*.a" *************** char __gnat_path_separator = PATH_SEPARA *** 206,213 **** const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE; /* The following macro HAVE_READDIR_R should be defined if the ! system provides the routine readdir_r */ #undef HAVE_READDIR_R void --- 205,238 ---- const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE; + /* This variable is used in hostparm.ads to say whether the host is a VMS + system. */ + #ifdef VMS + const int __gnat_vmsp = 1; + #else + 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_mon *** 234,240 **** *p_hours = res->tm_hour; *p_mins = res->tm_min; *p_secs = res->tm_sec; ! } else *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0; } --- 259,265 ---- *p_hours = res->tm_hour; *p_mins = res->tm_min; *p_secs = res->tm_sec; ! } else *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0; } *************** __gnat_readlink (path, buf, bufsiz) *** 261,270 **** #endif } ! /* Creates a symbolic link named newpath ! which contains the string oldpath. ! If newpath exists it will NOT be overwritten. ! For Windows, OS/2, vxworks, Interix and VMS, always retur -1. */ int __gnat_symlink (oldpath, newpath) --- 286,294 ---- #endif } ! /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If ! NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks, ! Interix and VMS, always return -1. */ int __gnat_symlink (oldpath, newpath) *************** __gnat_symlink (oldpath, newpath) *** 282,288 **** #endif } ! /* Try to lock a file, return 1 if success */ #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32) --- 306,312 ---- #endif } ! /* Try to lock a file, return 1 if success. */ #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32) *************** __gnat_try_lock (dir, file) *** 293,306 **** char *dir; char *file; { ! char full_path [256]; int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); fd = open (full_path, O_CREAT | O_EXCL, 0600); ! if (fd < 0) { return 0; ! } close (fd); return 1; } --- 317,330 ---- char *dir; char *file; { ! char full_path[256]; int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); fd = open (full_path, O_CREAT | O_EXCL, 0600); ! if (fd < 0) return 0; ! close (fd); return 1; } *************** __gnat_try_lock (dir, file) *** 315,321 **** char *dir; char *file; { ! char full_path [256]; int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); --- 339,345 ---- char *dir; char *file; { ! char full_path[256]; int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); *************** __gnat_try_lock (dir, file) *** 328,333 **** --- 352,358 ---- } #else + /* Version using link(), more secure over NFS. */ int *************** __gnat_try_lock (dir, file) *** 335,360 **** char *dir; char *file; { ! char full_path [256]; ! char temp_file [256]; struct stat stat_result; 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); if (fd < 0) return 0; close (fd); ! /* Link it with the new file */ link (temp_file, full_path); /* Count the references on the old one. If we have a count of two, then ! the link did succeed. Remove the temporary file before returning. */ __gnat_stat (temp_file, &stat_result); unlink (temp_file); return stat_result.st_nlink == 2; --- 360,385 ---- char *dir; char *file; { ! char full_path[256]; ! char temp_file[256]; struct stat stat_result; 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); if (fd < 0) return 0; close (fd); ! /* Link it with the new file. */ link (temp_file, full_path); /* Count the references on the old one. If we have a count of two, then ! the link did succeed. Remove the temporary file before returning. */ __gnat_stat (temp_file, &stat_result); unlink (temp_file); return stat_result.st_nlink == 2; *************** __gnat_try_lock (dir, file) *** 366,372 **** int __gnat_get_maximum_file_name_length () { ! #if defined(MSDOS) return 8; #elif defined (VMS) if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS")) --- 391,397 ---- int __gnat_get_maximum_file_name_length () { ! #if defined (MSDOS) return 8; #elif defined (VMS) if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS")) *************** __gnat_get_maximum_file_name_length () *** 378,401 **** #endif } - /* Return the default switch character. */ - - char - __gnat_get_switch_character () - { - /* Under MSDOS, the switch character is not normally a hyphen, but this is - the convention DJGPP uses. Similarly under OS2, the switch character is - not normally a hypen, but this is the convention EMX uses. */ - - return '-'; - } - /* 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; #else return 1; --- 403,414 ---- #endif } /* 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; #else return 1; *************** __gnat_get_default_identifier_character_ *** 412,418 **** #endif } ! /* Return the current working directory */ void __gnat_get_current_dir (dir, length) --- 425,431 ---- #endif } ! /* Return the current working directory. */ void __gnat_get_current_dir (dir, length) *************** __gnat_get_current_dir (dir, length) *** 428,439 **** *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) --- 441,452 ---- *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) *************** __gnat_get_object_suffix_ptr (len, value *** 450,456 **** return; } ! /* Return the suffix for executable files */ void __gnat_get_executable_suffix_ptr (len, value) --- 463,469 ---- return; } ! /* Return the suffix for executable files. */ void __gnat_get_executable_suffix_ptr (len, value) *************** __gnat_get_executable_suffix_ptr (len, v *** 467,473 **** } /* Return the suffix for debuggable files. Usually this is the same as the ! executable extension. */ void __gnat_get_debuggable_suffix_ptr (len, value) --- 480,486 ---- } /* Return the suffix for debuggable files. Usually this is the same as the ! executable extension. */ void __gnat_get_debuggable_suffix_ptr (len, value) *************** __gnat_get_debuggable_suffix_ptr (len, v *** 477,483 **** #ifndef MSDOS *value = HOST_EXECUTABLE_SUFFIX; #else ! /* On DOS, the extensionless COFF file is what gdb likes. */ *value = ""; #endif --- 490,496 ---- #ifndef MSDOS *value = HOST_EXECUTABLE_SUFFIX; #else ! /* On DOS, the extensionless COFF file is what gdb likes. */ *value = ""; #endif *************** __gnat_open_read (path, fmode) *** 500,514 **** if (fmode) o_fmode = O_TEXT; ! #if defined(VMS) ! /* Optional arguments mbc,deq,fop increase read performance */ fd = open (path, O_RDONLY | o_fmode, 0444, "mbc=16", "deq=64", "fop=tef"); ! #elif defined(__vxworks) fd = open (path, O_RDONLY | o_fmode, 0444); #else fd = open (path, O_RDONLY | o_fmode); #endif return fd < 0 ? -1 : fd; } --- 513,528 ---- if (fmode) o_fmode = O_TEXT; ! #if defined (VMS) ! /* Optional arguments mbc,deq,fop increase read performance. */ fd = open (path, O_RDONLY | o_fmode, 0444, "mbc=16", "deq=64", "fop=tef"); ! #elif defined (__vxworks) fd = open (path, O_RDONLY | o_fmode, 0444); #else fd = open (path, O_RDONLY | o_fmode); #endif + return fd < 0 ? -1 : fd; } *************** __gnat_open_rw (path, fmode) *** 529,535 **** if (fmode) o_fmode = O_TEXT; ! #if defined(VMS) fd = open (path, O_RDWR | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else --- 543,549 ---- if (fmode) o_fmode = O_TEXT; ! #if defined (VMS) fd = open (path, O_RDWR | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else *************** __gnat_open_create (path, fmode) *** 550,556 **** if (fmode) o_fmode = O_TEXT; ! #if defined(VMS) fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else --- 564,570 ---- if (fmode) o_fmode = O_TEXT; ! #if defined (VMS) fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else *************** __gnat_open_append (path, fmode) *** 571,577 **** if (fmode) o_fmode = O_TEXT; ! #if defined(VMS) fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else --- 585,591 ---- if (fmode) o_fmode = O_TEXT; ! #if defined (VMS) fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else *************** __gnat_open_append (path, fmode) *** 581,587 **** return fd < 0 ? -1 : fd; } ! /* Open a new file. Return error (-1) if the file already exists. */ int __gnat_open_new (path, fmode) --- 595,601 ---- return fd < 0 ? -1 : fd; } ! /* Open a new file. Return error (-1) if the file already exists. */ int __gnat_open_new (path, fmode) *************** __gnat_open_new (path, fmode) *** 594,600 **** if (fmode) o_fmode = O_TEXT; ! #if defined(VMS) fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else --- 608,614 ---- if (fmode) o_fmode = O_TEXT; ! #if defined (VMS) fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else *************** __gnat_open_new (path, fmode) *** 605,613 **** } /* Open a new temp file. Return error (-1) if the file already exists. ! Special options for VMS allow the file to be shared between parent and ! child processes, however they really slow down output. Used in ! gnatchop. */ int __gnat_open_new_temp (path, fmode) --- 619,626 ---- } /* Open a new temp file. Return error (-1) if the file already exists. ! Special options for VMS allow the file to be shared between parent and child ! processes, however they really slow down output. Used in gnatchop. */ int __gnat_open_new_temp (path, fmode) *************** __gnat_open_new_temp (path, fmode) *** 631,637 **** if (fmode) o_fmode = O_TEXT; ! #if defined(VMS) fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef"); --- 644,650 ---- if (fmode) o_fmode = O_TEXT; ! #if defined (VMS) fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef"); *************** __gnat_open_new_temp (path, fmode) *** 642,666 **** return fd < 0 ? -1 : fd; } ! int ! __gnat_mkdir (dir_name) ! char *dir_name; ! { ! /* On some systems, mkdir has two args and on some it has one. If we ! are being built as part of the compiler, autoconf has figured that out ! for us. Otherwise, we have to do it ourselves. */ ! #ifndef IN_RTS ! return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO); ! #else ! #if defined (_WIN32) || defined (__vxworks) ! return mkdir (dir_name); ! #else ! return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO); ! #endif ! #endif ! } ! ! /* Return the number of bytes in the specified file. */ long __gnat_file_length (fd) --- 655,661 ---- return fd < 0 ? -1 : fd; } ! /* Return the number of bytes in the specified file. */ long __gnat_file_length (fd) *************** __gnat_file_length (fd) *** 677,683 **** } /* Create a temporary filename and put it in string pointed to by ! tmp_filename */ void __gnat_tmp_name (tmp_filename) --- 672,678 ---- } /* Create a temporary filename and put it in string pointed to by ! TMP_FILENAME. */ void __gnat_tmp_name (tmp_filename) *************** __gnat_tmp_name (tmp_filename) *** 694,701 **** 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] == '\\') { --- 689,696 ---- 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] == '\\') { *************** __gnat_tmp_name (tmp_filename) *** 707,719 **** 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 --- 702,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 *************** win32_filetime (h) *** 779,785 **** 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 --- 775,781 ---- 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 *************** __gnat_file_time_name (name) *** 821,827 **** (void) __gnat_stat (name, &statbuf); #ifdef VMS ! /* VMS has file versioning */ return statbuf.st_ctime; #else return statbuf.st_mtime; --- 817,823 ---- (void) __gnat_stat (name, &statbuf); #ifdef VMS ! /* VMS has file versioning. */ return statbuf.st_ctime; #else return statbuf.st_mtime; *************** __gnat_file_time_fd (fd) *** 839,845 **** DJGPP fstat attempts to convert time values to GMT rather than keep the actual OS timestamp of the file. By using the OS2/DOS functions directly the GNAT timestamp are independent of this behavior, which is desired to ! facilitate the distribution of GNAT compiled libraries. */ #if defined (__EMX__) || defined (MSDOS) #ifdef __EMX__ --- 835,841 ---- DJGPP fstat attempts to convert time values to GMT rather than keep the actual OS timestamp of the file. By using the OS2/DOS functions directly the GNAT timestamp are independent of this behavior, which is desired to ! facilitate the distribution of GNAT compiled libraries. */ #if defined (__EMX__) || defined (MSDOS) #ifdef __EMX__ *************** __gnat_file_time_fd (fd) *** 871,880 **** the whole days passed. The value for years returned by the DOS and OS2 functions count years from 1980, so to compensate for the UNIX epoch which begins in 1970 start with 10 years worth of days and add days for each ! four year period since then. */ time_t tot_secs; ! int cum_days [12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; int days_passed = 3652 + (file_year / 4) * 1461; int years_since_leap = file_year % 4; --- 867,876 ---- the whole days passed. The value for years returned by the DOS and OS2 functions count years from 1980, so to compensate for the UNIX epoch which begins in 1970 start with 10 years worth of days and add days for each ! four year period since then. */ time_t tot_secs; ! int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; int days_passed = 3652 + (file_year / 4) * 1461; int years_since_leap = file_year % 4; *************** __gnat_file_time_fd (fd) *** 888,900 **** if (file_year > 20) days_passed -= 1; ! days_passed += cum_days [file_month - 1]; if (years_since_leap == 0 && file_year != 20 && file_month > 2) days_passed++; days_passed += file_day - 1; ! /* OK - have whole days. Multiply -- then add in other parts. */ tot_secs = days_passed * 86400; tot_secs += file_hour * 3600; --- 884,896 ---- if (file_year > 20) days_passed -= 1; ! days_passed += cum_days[file_month - 1]; if (years_since_leap == 0 && file_year != 20 && file_month > 2) days_passed++; days_passed += file_day - 1; ! /* OK - have whole days. Multiply -- then add in other parts. */ tot_secs = days_passed * 86400; tot_secs += file_hour * 3600; *************** __gnat_file_time_fd (fd) *** 905,911 **** #elif defined (_WIN32) HANDLE h = (HANDLE) _get_osfhandle (fd); time_t ret = win32_filetime (h); - CloseHandle (h); return ret; #else --- 901,906 ---- *************** __gnat_file_time_fd (fd) *** 914,920 **** (void) fstat (fd, &statbuf); #ifdef VMS ! /* VMS has file versioning */ return statbuf.st_ctime; #else return statbuf.st_mtime; --- 909,915 ---- (void) fstat (fd, &statbuf); #ifdef VMS ! /* VMS has file versioning. */ return statbuf.st_ctime; #else return statbuf.st_mtime; *************** __gnat_file_time_fd (fd) *** 922,928 **** #endif } ! /* Set the file time stamp */ void __gnat_set_file_time_name (name, time_stamp) --- 917,923 ---- #endif } ! /* Set the file time stamp. */ void __gnat_set_file_time_name (name, time_stamp) *************** __gnat_set_file_time_name (name, time_st *** 932,938 **** #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; --- 927,933 ---- #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; *************** __gnat_set_file_time_name (name, time_st *** 953,967 **** unsigned world : 4; } bits; } prot; ! } Fat = { 0 }; ! ATRDEF atrlst [] = { { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create }, { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise }, { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire }, { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup }, ! n{ ATR$S_FPRO, ATR$C_FPRO, &Fat.prot }, { ATR$S_UIC, ATR$C_UIC, &Fat.uic }, { 0, 0, 0} }; --- 948,962 ---- unsigned world : 4; } bits; } prot; ! } Fat = { 0, 0, 0, 0, 0, { 0 }}; ! ATRDEF atrlst[] = { { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create }, { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise }, { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire }, { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup }, ! { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot }, { ATR$S_UIC, ATR$C_UIC, &Fat.uic }, { 0, 0, 0} }; *************** __gnat_set_file_time_name (name, time_st *** 991,997 **** tryfile = (char *) __gnat_to_host_dir_spec (name, 0); ! /* Allocate and initialize a fab and nam structures. */ fab = cc$rms_fab; nam = cc$rms_nam; --- 986,992 ---- tryfile = (char *) __gnat_to_host_dir_spec (name, 0); ! /* Allocate and initialize a FAB and NAM structures. */ fab = cc$rms_fab; nam = cc$rms_nam; *************** __gnat_set_file_time_name (name, time_st *** 1003,1024 **** fab.fab$b_fns = strlen (tryfile); fab.fab$l_nam = &nam; ! /*Validate filespec syntax and device existence. */ status = SYS$PARSE (&fab, 0, 0); if ((status & 1) != 1) LIB$SIGNAL (status); ! file.string [nam.nam$b_esl] = 0; ! /* Find matching filespec. */ status = SYS$SEARCH (&fab, 0, 0); if ((status & 1) != 1) LIB$SIGNAL (status); ! file.string [nam.nam$b_esl] = 0; ! result.string [result.length=nam.nam$b_rsl] = 0; ! /* Get the device name and assign an IO channel. */ strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev); devicedsc.dsc$w_length = nam.nam$b_dev; chan = 0; --- 998,1019 ---- fab.fab$b_fns = strlen (tryfile); fab.fab$l_nam = &nam; ! /* Validate filespec syntax and device existence. */ status = SYS$PARSE (&fab, 0, 0); if ((status & 1) != 1) LIB$SIGNAL (status); ! file.string[nam.nam$b_esl] = 0; ! /* Find matching filespec. */ status = SYS$SEARCH (&fab, 0, 0); if ((status & 1) != 1) LIB$SIGNAL (status); ! file.string[nam.nam$b_esl] = 0; ! result.string[result.length=nam.nam$b_rsl] = 0; ! /* Get the device name and assign an IO channel. */ strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev); devicedsc.dsc$w_length = nam.nam$b_dev; chan = 0; *************** __gnat_set_file_time_name (name, time_st *** 1026,1041 **** if ((status & 1) != 1) LIB$SIGNAL (status); ! /* Initialize the FIB and fill in the directory id field. */ ! bzero (&fib, sizeof (fib)); ! fib.fib$w_did [0] = nam.nam$w_did [0]; ! fib.fib$w_did [1] = nam.nam$w_did [1]; ! fib.fib$w_did [2] = nam.nam$w_did [2]; fib.fib$l_acctl = 0; fib.fib$l_wcc = 0; strcpy (file.string, (strrchr (result.string, ']') + 1)); filedsc.dsc$w_length = strlen (file.string); ! result.string [result.length = 0] = 0; /* Open and close the file to fill in the attributes. */ status --- 1021,1036 ---- if ((status & 1) != 1) LIB$SIGNAL (status); ! /* Initialize the FIB and fill in the directory id field. */ ! memset (&fib, 0, sizeof (fib)); ! fib.fib$w_did[0] = nam.nam$w_did[0]; ! fib.fib$w_did[1] = nam.nam$w_did[1]; ! fib.fib$w_did[2] = nam.nam$w_did[2]; fib.fib$l_acctl = 0; fib.fib$l_wcc = 0; strcpy (file.string, (strrchr (result.string, ']') + 1)); filedsc.dsc$w_length = strlen (file.string); ! result.string[result.length = 0] = 0; /* Open and close the file to fill in the attributes. */ status *************** __gnat_set_file_time_name (name, time_st *** 1046,1074 **** if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); ! result.string [result.length] = 0; ! status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, ! &fibdsc, 0, 0, 0, &atrlst, 0); if ((status & 1) != 1) LIB$SIGNAL (status); if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); - /* Set creation time to requested time */ - unix_time_to_vms (time_stamp, newtime); - { time_t t; struct tm *ts; 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. */ fib.fib$l_acctl = FIB$M_WRITE; status = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0, --- 1041,1071 ---- if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); ! result.string[result.length] = 0; ! status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0, ! &atrlst, 0); if ((status & 1) != 1) LIB$SIGNAL (status); if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); { 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. */ fib.fib$l_acctl = FIB$M_WRITE; status = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0, *************** __gnat_set_file_time_name (name, time_st *** 1088,1094 **** if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); ! /* Deassign the channel and exit. */ status = SYS$DASSGN (chan); if ((status & 1) != 1) LIB$SIGNAL (status); --- 1085,1091 ---- if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); ! /* Deassign the channel and exit. */ status = SYS$DASSGN (chan); if ((status & 1) != 1) LIB$SIGNAL (status); *************** __gnat_set_file_time_name (name, time_st *** 1096,1105 **** struct utimbuf utimbuf; time_t t; ! /* Set modification time to requested time */ utimbuf.modtime = time_stamp; ! /* Set access time to now in local time */ t = time ((time_t) 0); utimbuf.actime = mktime (localtime (&t)); --- 1093,1102 ---- struct utimbuf utimbuf; time_t t; ! /* Set modification time to requested time. */ utimbuf.modtime = time_stamp; ! /* Set access time to now in local time. */ t = time ((time_t) 0); utimbuf.actime = mktime (localtime (&t)); *************** __gnat_get_env_value_ptr (name, len, val *** 1126,1132 **** #ifdef VMS ! static char *to_host_path_spec PROTO ((char *)); struct descriptor_s { --- 1123,1129 ---- #ifdef VMS ! static char *to_host_path_spec PARAMS ((char *)); struct descriptor_s { *************** __gnat_set_env_value (name, value) *** 1152,1158 **** #elif defined (VMS) 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; --- 1149,1155 ---- #elif defined (VMS) 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; *************** __gnat_set_env_value (name, value) *** 1186,1207 **** next = strchr (curr, 0); *next = 0; ! ile_array [i].len = strlen (curr); ! /* Code 2 from lnmdef.h means its a string */ ! ile_array [i].code = 2; ! ile_array [i].adr = curr; ! /* retlen_adr is ignored */ ! ile_array [i].retlen_adr = 0; curr = next + 1; } ! /* Terminating item must be zero */ ! ile_array [i].len = 0; ! ile_array [i].code = 0; ! ile_array [i].adr = 0; ! ile_array [i].retlen_adr = 0; status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array); if ((status & 1) != 1) --- 1183,1204 ---- next = strchr (curr, 0); *next = 0; ! ile_array[i].len = strlen (curr); ! /* Code 2 from lnmdef.h means its a string. */ ! ile_array[i].code = 2; ! ile_array[i].adr = curr; ! /* retlen_adr is ignored. */ ! ile_array[i].retlen_adr = 0; curr = next + 1; } ! /* Terminating item must be zero. */ ! ile_array[i].len = 0; ! ile_array[i].code = 0; ! ile_array[i].adr = 0; ! ile_array[i].retlen_adr = 0; status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array); if ((status & 1) != 1) *************** __gnat_stat (name, statbuf) *** 1291,1309 **** /* 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); while (name_len > 1 && (last_char == '\\' || last_char == '/')) { ! win32_name [name_len - 1] = '\0'; name_len--; last_char = win32_name[name_len - 1]; } ! if (name_len == 2 && win32_name [1] == ':') strcat (win32_name, "\\"); return stat (win32_name, statbuf); --- 1288,1306 ---- /* 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); while (name_len > 1 && (last_char == '\\' || last_char == '/')) { ! win32_name[name_len - 1] = '\0'; name_len--; last_char = win32_name[name_len - 1]; } ! if (name_len == 2 && win32_name[1] == ':') strcat (win32_name, "\\"); return stat (win32_name, statbuf); *************** __gnat_is_absolute_path (name) *** 1327,1334 **** char *name; { return (*name == '/' || *name == DIR_SEPARATOR ! #if defined(__EMX__) || defined(MSDOS) || defined(WINNT) ! || strlen (name) > 1 && isalpha (name [0]) && name [1] == ':' #endif ); } --- 1324,1331 ---- char *name; { return (*name == '/' || *name == DIR_SEPARATOR ! #if defined (__EMX__) || defined (MSDOS) || defined (WINNT) ! || strlen (name) > 1 && isalpha (name[0]) && name[1] == ':' #endif ); } *************** __gnat_is_writable_file (name) *** 1369,1375 **** } #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 --- 1366,1372 ---- } #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 *************** __gnat_portable_spawn (args) *** 1390,1436 **** int pid; #if defined (MSDOS) || defined (_WIN32) ! status = spawnvp (P_WAIT, args [0], args); if (status < 0) ! return 4; else return status; ! #elif defined(__vxworks) /* Mods for VxWorks */ ! pid = sp (args[0], args); /* Spawn process and save pid */ ! if (pid == -1) ! return (4); ! ! while (taskIdVerify(pid) >= 0) ! /* Wait until spawned task is complete then continue. */ ! ; #else #ifdef __EMX__ ! pid = spawnvp (P_NOWAIT, args [0], args); if (pid == -1) ! return (4); #else pid = fork (); ! if (pid == -1) ! return (4); ! if (pid == 0 && execv (args [0], args) != 0) ! _exit (1); #endif ! /* The parent */ finished = waitpid (pid, &status, 0); if (finished != pid || WIFEXITED (status) == 0) ! return 4; return WEXITSTATUS (status); #endif return 0; } ! /* WIN32 code to implement a wait call that wait for any child process */ #ifdef _WIN32 /* Synchronization code, to be thread safe. */ --- 1387,1438 ---- int pid; #if defined (MSDOS) || defined (_WIN32) ! status = spawnvp (P_WAIT, args[0], args); if (status < 0) ! return -1; else return status; ! #elif defined (__vxworks) ! return -1; #else #ifdef __EMX__ ! pid = spawnvp (P_NOWAIT, args[0], args); if (pid == -1) ! return -1; ! #else pid = fork (); ! if (pid < 0) ! return -1; ! if (pid == 0) ! { ! /* The child. */ ! if (execv (args[0], args) != 0) ! #if defined (VMS) ! return -1; /* execv is in parent context on VMS. */ ! #else ! _exit (1); ! #endif ! } #endif ! /* The parent. */ finished = waitpid (pid, &status, 0); if (finished != pid || WIFEXITED (status) == 0) ! return -1; return WEXITSTATUS (status); #endif + return 0; } ! /* WIN32 code to implement a wait call that wait for any child process. */ ! #ifdef _WIN32 /* Synchronization code, to be thread safe. */ *************** plist_enter () *** 1449,1455 **** EnterCriticalSection (&plist_cs); } ! void plist_leave () { LeaveCriticalSection (&plist_cs); --- 1451,1457 ---- EnterCriticalSection (&plist_cs); } ! static void plist_leave () { LeaveCriticalSection (&plist_cs); *************** win32_no_block_spawn (command, args) *** 1527,1536 **** STARTUPINFO SI; PROCESS_INFORMATION PI; SECURITY_ATTRIBUTES SA; ! ! char full_command [2000]; int k; /* Startup info. */ SI.cb = sizeof (STARTUPINFO); SI.lpReserved = NULL; --- 1529,1548 ---- STARTUPINFO SI; PROCESS_INFORMATION PI; SECURITY_ATTRIBUTES SA; ! int csize = 1; ! char *full_command; int k; + /* compute the total command line length */ + k = 0; + while (args[k]) + { + csize += strlen (args[k]) + 1; + k++; + } + + full_command = (char *) xmalloc (csize); + /* Startup info. */ SI.cb = sizeof (STARTUPINFO); SI.lpReserved = NULL; *************** win32_no_block_spawn (command, args) *** 1561,1566 **** --- 1573,1580 ---- result = CreateProcess (NULL, (char *) full_command, &SA, NULL, TRUE, NORMAL_PRIORITY_CLASS, NULL, NULL, &SI, &PI); + free (full_command); + if (result == TRUE) { add_handle (PI.hProcess); *************** win32_wait (status) *** 1605,1611 **** plist_leave(); res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE); ! h = hl [res - WAIT_OBJECT_0]; free (hl); remove_handle (h); --- 1619,1625 ---- plist_leave(); res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE); ! h = hl[res - WAIT_OBJECT_0]; free (hl); remove_handle (h); *************** __gnat_portable_no_block_spawn (args) *** 1635,1641 **** portable_wait below systematically returns a pid of 0 and reports that the subprocess terminated successfully. */ ! if (spawnvp (P_WAIT, args [0], args) != 0) return -1; #elif defined (_WIN32) --- 1649,1655 ---- portable_wait below systematically returns a pid of 0 and reports that the subprocess terminated successfully. */ ! if (spawnvp (P_WAIT, args[0], args) != 0) return -1; #elif defined (_WIN32) *************** __gnat_portable_no_block_spawn (args) *** 1643,1660 **** pid = win32_no_block_spawn (args[0], args); return pid; ! #elif defined (__vxworks) /* Mods for VxWorks */ ! pid = sp (args[0], args); /* Spawn task and then return (no waiting) */ ! if (pid == -1) ! return (4); ! ! return pid; #else pid = fork (); ! if (pid == 0 && execv (args [0], args) != 0) ! _exit (1); #endif return pid; --- 1657,1679 ---- pid = win32_no_block_spawn (args[0], args); return pid; ! #elif defined (__vxworks) ! return -1; #else pid = fork (); ! if (pid == 0) ! { ! /* The child. */ ! if (execv (args[0], args) != 0) ! #if defined (VMS) ! return -1; /* execv is in parent context on VMS. */ ! #else ! _exit (1); ! #endif ! } ! #endif return pid; *************** __gnat_portable_wait (process_status) *** 1672,1690 **** pid = win32_wait (&status); #elif defined (__EMX__) || defined (MSDOS) ! /* ??? See corresponding comment in portable_no_block_spawn. */ #elif defined (__vxworks) /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but ! return zero. */ #else - #ifdef VMS - /* Wait doesn't do the right thing on VMS */ pid = waitpid (-1, &status, 0); - #else - pid = wait (&status); - #endif status = status & 0xffff; #endif --- 1691,1704 ---- pid = win32_wait (&status); #elif defined (__EMX__) || defined (MSDOS) ! /* ??? See corresponding comment in portable_no_block_spawn. */ #elif defined (__vxworks) /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but ! return zero. */ #else pid = waitpid (-1, &status, 0); status = status & 0xffff; #endif *************** __gnat_portable_wait (process_status) *** 1692,1710 **** return pid; } 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) --- 1706,1742 ---- return pid; } + int + __gnat_waitpid (pid) + int pid; + { + int status = 0; + + #if defined (_WIN32) + cwait (&status, pid, _WAIT_CHILD); + #elif defined (__EMX__) || defined (MSDOS) || defined (__vxworks) + /* Status is already zero, so nothing to do. */ + #else + waitpid (pid, &status, 0); + status = WEXITSTATUS (status); + #endif + + return status; + } + 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) *************** __gnat_locate_regular_file (file_name, p *** 1713,1725 **** { 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 ) { --- 1745,1757 ---- { 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 ) { *************** __gnat_locate_regular_file (file_name, p *** 1761,1770 **** return 0; } - /* Locate an executable given a Path argument. This routine is only used by gnatbl and should not be used otherwise. Use locate_exec_on_path ! instead. */ char * __gnat_locate_exec (exec_name, path_val) --- 1793,1801 ---- return 0; } /* Locate an executable given a Path argument. This routine is only used by gnatbl and should not be used otherwise. Use locate_exec_on_path ! instead. */ char * __gnat_locate_exec (exec_name, path_val) *************** __gnat_locate_exec (exec_name, path_val) *** 1784,1790 **** return __gnat_locate_regular_file (exec_name, path_val); } ! /* Locate an executable using the Systems default PATH */ char * __gnat_locate_exec_on_path (exec_name) --- 1815,1821 ---- return __gnat_locate_regular_file (exec_name, path_val); } ! /* Locate an executable using the Systems default PATH. */ char * __gnat_locate_exec_on_path (exec_name) *************** __gnat_locate_exec_on_path (exec_name) *** 1804,1848 **** #ifdef VMS /* 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 */ if (ver) *ver = 0; ! /* Dynamically extend the allocation by the increment */ if (new_canonical_filelist_in_use == new_canonical_filelist_allocated) { new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT; ! new_canonical_filelist = (char **) realloc (new_canonical_filelist, new_canonical_filelist_allocated * sizeof (char *)); } --- 1835,1879 ---- #ifdef VMS /* 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. */ if (ver) *ver = 0; ! /* Dynamically extend the allocation by the increment. */ if (new_canonical_filelist_in_use == new_canonical_filelist_allocated) { new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT; ! new_canonical_filelist = (char **) xrealloc (new_canonical_filelist, new_canonical_filelist_allocated * sizeof (char *)); } *************** wildcard_translate_unix (name) *** 1852,1861 **** return 1; } ! /* Translate a wildcard VMS file spec into a list of Unix file ! specs. First do full translation and copy the results into a list (_init), ! then return them one at a time (_next). If onlydirs set, only expand ! directory files. */ int __gnat_to_canonical_file_list_init (filespec, onlydirs) --- 1883,1891 ---- return 1; } ! /* Translate a wildcard VMS file spec into a list of Unix file specs. First do ! full translation and copy the results into a list (_init), then return them ! one at a time (_next). If onlydirs set, only expand directory files. */ int __gnat_to_canonical_file_list_init (filespec, onlydirs) *************** __gnat_to_canonical_file_list_init (file *** 1863,1880 **** 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); ! /* Remove the .dir extension */ if (onlydirs) { int i; --- 1893,1910 ---- 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); ! /* Remove the .dir extension. */ if (onlydirs) { int i; *************** __gnat_to_canonical_file_list_init (file *** 1882,1888 **** for (i = 0; i < new_canonical_filelist_in_use; i++) { ! ext = strstr (new_canonical_filelist [i], ".dir"); if (ext) *ext = 0; } --- 1912,1918 ---- for (i = 0; i < new_canonical_filelist_in_use; i++) { ! ext = strstr (new_canonical_filelist[i], ".dir"); if (ext) *ext = 0; } *************** __gnat_to_canonical_file_list_init (file *** 1891,1905 **** return new_canonical_filelist_in_use; } ! /* Return the next filespec in the list */ char * __gnat_to_canonical_file_list_next () { ! return new_canonical_filelist [new_canonical_filelist_index++]; } ! /* Free up storage used in the wildcard expansion */ void __gnat_to_canonical_file_list_free () --- 1921,1935 ---- return new_canonical_filelist_in_use; } ! /* Return the next filespec in the list. */ char * __gnat_to_canonical_file_list_next () { ! return new_canonical_filelist[new_canonical_filelist_index++]; } ! /* Free storage used in the wildcard expansion. */ void __gnat_to_canonical_file_list_free () *************** __gnat_to_canonical_file_list_free () *** 1907,1913 **** int i; for (i = 0; i < new_canonical_filelist_in_use; i++) ! free (new_canonical_filelist [i]); free (new_canonical_filelist); --- 1937,1943 ---- int i; for (i = 0; i < new_canonical_filelist_in_use; i++) ! free (new_canonical_filelist[i]); free (new_canonical_filelist); *************** __gnat_to_canonical_file_list_free () *** 1917,1929 **** new_canonical_filelist = 0; } ! /* Translate a VMS syntax directory specification in to Unix syntax. ! If prefixflag is set, append an underscore "/". If no indicators ! of VMS syntax found, return input string. Also translate a dirname ! that contains no slashes, in case it's a logical name. */ char * ! __gnat_to_canonical_dir_spec (dirspec,prefixflag) char *dirspec; int prefixflag; { --- 1947,1959 ---- new_canonical_filelist = 0; } ! /* Translate a VMS syntax directory specification in to Unix syntax. If ! PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax ! found, return input string. Also translate a dirname that contains no ! slashes, in case it's a logical name. */ char * ! __gnat_to_canonical_dir_spec (dirspec, prefixflag) char *dirspec; int prefixflag; { *************** __gnat_to_canonical_dir_spec (dirspec,pr *** 1943,1949 **** } len = strlen (new_canonical_dirspec); ! if (prefixflag && new_canonical_dirspec [len-1] != '/') strcat (new_canonical_dirspec, "/"); return new_canonical_dirspec; --- 1973,1979 ---- } len = strlen (new_canonical_dirspec); ! if (prefixflag && new_canonical_dirspec[len - 1] != '/') strcat (new_canonical_dirspec, "/"); return new_canonical_dirspec; *************** __gnat_to_canonical_dir_spec (dirspec,pr *** 1951,1957 **** } /* Translate a VMS syntax file specification into Unix syntax. ! If no indicators of VMS syntax found, return input string. */ char * __gnat_to_canonical_file_spec (filespec) --- 1981,1987 ---- } /* Translate a VMS syntax file specification into Unix syntax. ! If no indicators of VMS syntax found, return input string. */ char * __gnat_to_canonical_file_spec (filespec) *************** __gnat_to_canonical_file_spec (filespec) *** 1967,1988 **** } /* Translate a VMS syntax path specification into Unix syntax. ! 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; ! /* If there are /'s, assume it's a Unix path spec and return */ if (strchr (pathspec, '/')) return pathspec; ! new_canonical_pathspec [0] = 0; curr = pathspec; for (;;) --- 1997,2018 ---- } /* Translate a VMS syntax path specification into Unix syntax. ! 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; ! /* If there are /'s, assume it's a Unix path spec and return. */ if (strchr (pathspec, '/')) return pathspec; ! new_canonical_pathspec[0] = 0; curr = pathspec; for (;;) *************** __gnat_to_canonical_path_spec (pathspec) *** 1992,2000 **** next = strchr (curr, 0); strncpy (buff, curr, next - curr); ! buff [next - curr] = 0; ! /* Check for wildcards and expand if present */ if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "...")) { int i, dirs; --- 2022,2030 ---- next = strchr (curr, 0); strncpy (buff, curr, next - curr); ! buff[next - curr] = 0; ! /* Check for wildcards and expand if present. */ if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "...")) { int i, dirs; *************** __gnat_to_canonical_path_spec (pathspec) *** 2007,2013 **** 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, ":"); } --- 2037,2043 ---- 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_path_spec (pathspec) *** 2028,2034 **** return new_canonical_pathspec; } ! static char filename_buff [256]; static int translate_unix (name, type) --- 2058,2064 ---- return new_canonical_pathspec; } ! static char filename_buff[256]; static int translate_unix (name, type) *************** translate_unix (name, type) *** 2039,2061 **** return 0; } ! /* Translate a Unix syntax path spec into a VMS style (comma separated ! list of directories. Only used in this file so make it static */ static char * to_host_path_spec (pathspec) char *pathspec; { ! char *curr, *next, buff [256]; if (pathspec == 0) return pathspec; ! /* Can't very well test for colons, since that's the Unix separator! */ if (strchr (pathspec, ']') || strchr (pathspec, ',')) return pathspec; ! new_host_pathspec [0] = 0; curr = pathspec; for (;;) --- 2069,2091 ---- return 0; } ! /* Translate a Unix syntax path spec into a VMS style (comma separated list of ! directories. */ static char * to_host_path_spec (pathspec) char *pathspec; { ! char *curr, *next, buff[256]; if (pathspec == 0) return pathspec; ! /* Can't very well test for colons, since that's the Unix separator! */ if (strchr (pathspec, ']') || strchr (pathspec, ',')) return pathspec; ! new_host_pathspec[0] = 0; curr = pathspec; for (;;) *************** to_host_path_spec (pathspec) *** 2065,2071 **** next = strchr (curr, 0); strncpy (buff, curr, next - curr); ! buff [next - curr] = 0; strcat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0)); if (*next == 0) --- 2095,2101 ---- next = strchr (curr, 0); strncpy (buff, curr, next - curr); ! buff[next - curr] = 0; strcat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0)); if (*next == 0) *************** to_host_path_spec (pathspec) *** 2077,2091 **** return new_host_pathspec; } ! /* Translate a Unix syntax directory specification into VMS syntax. ! The prefixflag has no effect, but is kept for symmetry with ! to_canonical_dir_spec. ! If indicators of VMS syntax found, return input string. */ char * __gnat_to_host_dir_spec (dirspec, prefixflag) char *dirspec; ! int prefixflag; { int len = strlen (dirspec); --- 2107,2121 ---- return new_host_pathspec; } ! /* Translate a Unix syntax directory specification into VMS syntax. The ! PREFIXFLAG has no effect, but is kept for symmetry with ! to_canonical_dir_spec. If indicators of VMS syntax found, return input ! string. */ char * __gnat_to_host_dir_spec (dirspec, prefixflag) char *dirspec; ! int prefixflag ATTRIBUTE_UNUSED; { int len = strlen (dirspec); *************** __gnat_to_host_dir_spec (dirspec, prefix *** 2094,2102 **** if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':')) return new_host_dirspec; ! while (len > 1 && new_host_dirspec [len-1] == '/') { ! new_host_dirspec [len-1] = 0; len--; } --- 2124,2132 ---- if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':')) return new_host_dirspec; ! while (len > 1 && new_host_dirspec[len - 1] == '/') { ! new_host_dirspec[len - 1] = 0; len--; } *************** __gnat_to_host_dir_spec (dirspec, prefix *** 2108,2114 **** } /* 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) --- 2138,2144 ---- } /* 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) *************** __gnat_adjust_os_resource_limits () *** 2134,2140 **** #else ! /* Dummy functions for Osint import for non-VMS systems */ int __gnat_to_canonical_file_list_init (dirspec, onlydirs) --- 2164,2170 ---- #else ! /* Dummy functions for Osint import for non-VMS systems. */ int __gnat_to_canonical_file_list_init (dirspec, onlydirs) *************** __gnat_adjust_os_resource_limits () *** 2199,2207 **** #endif ! /* for EMX, we cannot include dummy in libgcc, since it is too difficult to coordinate this with the EMX distribution. Consequently, we put the ! definition of dummy() which is used for exception handling, here */ #if defined (__EMX__) void __dummy () {} --- 2229,2237 ---- #endif ! /* For EMX, we cannot include dummy in libgcc, since it is too difficult to coordinate this with the EMX distribution. Consequently, we put the ! definition of dummy which is used for exception handling, here. */ #if defined (__EMX__) void __dummy () {} *************** int _flush_cache() *** 2217,2229 **** #if defined (CROSS_COMPILE) \ || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \ && ! defined (linux) \ - && ! defined (sgi) \ && ! defined (hpux) \ && ! (defined (__alpha__) && defined (__osf__)) \ && ! defined (__MINGW32__)) ! /* Dummy function to satisfy g-trasym.o. ! Currently Solaris sparc, HP/UX, IRIX, GNU/Linux, Tru64 & Windows provide a ! non-dummy version of this procedure in libaddr2line.a */ void convert_addresses (addrs, n_addr, buf, len) --- 2247,2259 ---- #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) *************** convert_addresses (addrs, n_addr, buf, l *** 2235,2237 **** --- 2265,2273 ---- *len = 0; } #endif + + #if defined (_WIN32) + int __gnat_argument_needs_quote = 1; + #else + int __gnat_argument_needs_quote = 0; + #endif diff -Nrc3pad gcc-3.2.3/gcc/ada/adaint.h gcc-3.3/gcc/ada/adaint.h *** gcc-3.2.3/gcc/ada/adaint.h 2003-01-29 17:34:09.000000000 +0000 --- gcc-3.3/gcc/ada/adaint.h 2003-01-29 17:40:47.000000000 +0000 *************** *** 4,14 **** * * * A D A I N T * * * - * $Revision: 1.5.2.1.4.1 $ * * * 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- * --- 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- * *************** *** 38,49 **** #include 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 char __gnat_get_switch_character 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)); --- 37,48 ---- #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 int __gnat_is_writable_file *** 84,89 **** --- 83,89 ---- 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 *)); diff -Nrc3pad gcc-3.2.3/gcc/ada/ada-tree.def gcc-3.3/gcc/ada/ada-tree.def *** gcc-3.2.3/gcc/ada/ada-tree.def 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/ada-tree.def 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * Specification * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- *************** *** 35,52 **** DEFTREECODE (TRANSFORM_EXPR, "transform_expr", 'e', 0) - /* Perform an unchecked conversion between the input and the output. - if TREE_ADDRESSABLE is set, it means this is in an LHS; in that case, - we can only use techniques, such as pointer punning, that leave the - expression a "name". */ - - DEFTREECODE (UNCHECKED_CONVERT_EXPR, "unchecked_convert_expr", '1', 1) - /* Dynamically allocate on the stack a number of bytes of memory given 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 --- 34,44 ---- DEFTREECODE (TRANSFORM_EXPR, "transform_expr", 'e', 0) /* Dynamically allocate on the stack a number of bytes of memory given 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 diff -Nrc3pad gcc-3.2.3/gcc/ada/ada-tree.h gcc-3.3/gcc/ada/ada-tree.h *** gcc-3.2.3/gcc/ada/ada-tree.h 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/ada-tree.h 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * C Header File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- *************** enum gnat_tree_code { *** 35,40 **** --- 34,68 ---- }; #undef DEFTREECODE + /* A tree to hold a loop ID. */ + struct tree_loop_id GTY(()) + { + struct tree_common common; + struct nesting *loop_id; + }; + + /* 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)"))) + generic; + struct tree_loop_id GTY ((tag ("1"))) loop_id; + }; + + /* Ada uses the lang_decl and lang_type fields to hold more trees. */ + struct lang_decl GTY(()) + { + union lang_tree_node + GTY((desc ("TREE_CODE (&%h.generic) == GNAT_LOOP_ID"))) t; + }; + struct lang_type GTY(()) + { + union lang_tree_node + GTY((desc ("TREE_CODE (&%h.generic) == GNAT_LOOP_ID"))) t; + }; + /* Flags added to GCC type nodes. */ /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is a *************** enum gnat_tree_code { *** 115,131 **** || TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \ && TYPE_DUMMY_P (NODE)) - /* Nonzero if this corresponds to a type where alignment is guaranteed - by other mechanisms (a tagged or packed type). */ - #define TYPE_ALIGN_OK_P(NODE) TYPE_LANG_FLAG_5 (NODE) - /* For an INTEGER_TYPE, nonzero if TYPE_ACTUAL_BOUNDS is present. */ #define TYPE_HAS_ACTUAL_BOUNDS_P(NODE) \ ! TYPE_LANG_FLAG_6 (INTEGER_TYPE_CHECK (NODE)) /* For a RECORD_TYPE, nonzero if this was made just to supply needed padding or alignment. */ ! #define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_6 (RECORD_TYPE_CHECK (NODE)) /* This field is only defined for FUNCTION_TYPE nodes. If the Ada subprogram contains no parameters passed by copy in/copy out then this --- 143,155 ---- || TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \ && TYPE_DUMMY_P (NODE)) /* For an INTEGER_TYPE, nonzero if TYPE_ACTUAL_BOUNDS is present. */ #define TYPE_HAS_ACTUAL_BOUNDS_P(NODE) \ ! TYPE_LANG_FLAG_5 (INTEGER_TYPE_CHECK (NODE)) /* For a RECORD_TYPE, nonzero if this was made just to supply needed padding or alignment. */ ! #define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE)) /* This field is only defined for FUNCTION_TYPE nodes. If the Ada subprogram contains no parameters passed by copy in/copy out then this *************** enum gnat_tree_code { *** 134,162 **** by copy in copy out. It is a CONSTRUCTOR. For a full description of the cico parameter passing mechanism refer to the routine gnat_to_gnu_entity. */ #define TYPE_CI_CO_LIST(NODE) \ ! (tree) TYPE_LANG_SPECIFIC (FUNCTION_TYPE_CHECK (NODE)) /* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the modulus. */ #define TYPE_MODULUS(NODE) \ ! (tree) TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) /* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, points to the type corresponding to the Ada index type. */ #define TYPE_INDEX_TYPE(NODE) \ ! (tree) TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) /* 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)) /* For INTEGER_TYPE, stores the RM_Size of the type. */ #define TYPE_RM_SIZE_INT(NODE) TYPE_VALUES (INTEGER_TYPE_CHECK (NODE)) /* Likewise for ENUMERAL_TYPE. */ #define TYPE_RM_SIZE_ENUM(NODE) \ ! (tree) TYPE_LANG_SPECIFIC (ENUMERAL_TYPE_CHECK (NODE)) #define TYPE_RM_SIZE(NODE) \ (TREE_CODE (NODE) == ENUMERAL_TYPE ? TYPE_RM_SIZE_ENUM (NODE) \ --- 158,196 ---- by copy in copy out. It is a CONSTRUCTOR. For a full description of the cico parameter passing mechanism refer to the routine gnat_to_gnu_entity. */ #define TYPE_CI_CO_LIST(NODE) \ ! (&TYPE_LANG_SPECIFIC (FUNCTION_TYPE_CHECK (NODE))->t.generic) ! #define SET_TYPE_CI_CO_LIST(NODE, X) \ ! (TYPE_LANG_SPECIFIC (FUNCTION_TYPE_CHECK (NODE)) = (struct lang_type *)(X)) /* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the modulus. */ #define TYPE_MODULUS(NODE) \ ! (&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic) ! #define SET_TYPE_MODULUS(NODE, X) \ ! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *)(X)) /* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, points to the type corresponding to the Ada index type. */ #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)) /* Likewise for ENUMERAL_TYPE. */ #define TYPE_RM_SIZE_ENUM(NODE) \ ! (&TYPE_LANG_SPECIFIC (ENUMERAL_TYPE_CHECK (NODE))->t.generic) ! #define SET_TYPE_RM_SIZE_ENUM(NODE, X) \ ! (TYPE_LANG_SPECIFIC (ENUMERAL_TYPE_CHECK (NODE)) = (struct lang_type *)(X)) #define TYPE_RM_SIZE(NODE) \ (TREE_CODE (NODE) == ENUMERAL_TYPE ? TYPE_RM_SIZE_ENUM (NODE) \ *************** enum gnat_tree_code { *** 167,183 **** unconstrained object. Likewise for a RECORD_TYPE that is pointed to by a thin pointer. */ #define TYPE_UNCONSTRAINED_ARRAY(NODE) \ ! (tree) TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE)) /* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, the Ada size of the object. This differs from the GCC size in that it does not include any rounding up to the alignment of the type. */ ! #define TYPE_ADA_SIZE(NODE) (tree) TYPE_LANG_SPECIFIC (NODE) /* For an INTEGER_TYPE with TYPE_HAS_ACTUAL_BOUNDS_P or an ARRAY_TYPE, this is the index type that should be used when the actual bounds are required for a template. This is used in the case of packed arrays. */ ! #define TYPE_ACTUAL_BOUNDS(NODE) (tree) TYPE_LANG_SPECIFIC (NODE) /* In an UNCONSTRAINED_ARRAY_TYPE, points to the record containing both the template and object. */ --- 201,223 ---- unconstrained object. Likewise for a RECORD_TYPE that is pointed to by a thin pointer. */ #define TYPE_UNCONSTRAINED_ARRAY(NODE) \ ! (&TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE))->t.generic) ! #define SET_TYPE_UNCONSTRAINED_ARRAY(NODE, X) \ ! (TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE)) = (struct lang_type *)(X)) /* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, the Ada size of the object. This differs from the GCC size in that it does not include any rounding up to the alignment of the type. */ ! #define TYPE_ADA_SIZE(NODE) (&TYPE_LANG_SPECIFIC (NODE)->t.generic) ! #define SET_TYPE_ADA_SIZE(NODE, X) \ ! (TYPE_LANG_SPECIFIC (NODE) = (struct lang_type *)(X)) /* For an INTEGER_TYPE with TYPE_HAS_ACTUAL_BOUNDS_P or an ARRAY_TYPE, this is the index type that should be used when the actual bounds are required for a template. This is used in the case of packed arrays. */ ! #define TYPE_ACTUAL_BOUNDS(NODE) (&TYPE_LANG_SPECIFIC (NODE)->t.generic) ! #define SET_TYPE_ACTUAL_BOUNDS(NODE, X) \ ! (TYPE_LANG_SPECIFIC (NODE) = (struct lang_type *)(X)) /* In an UNCONSTRAINED_ARRAY_TYPE, points to the record containing both the template and object. */ *************** enum gnat_tree_code { *** 216,227 **** memory. Used when a scalar constant is aliased or has its address taken. */ #define DECL_CONST_CORRESPONDING_VAR(NODE) \ ! (tree) DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE)) /* In a FIELD_DECL, points to the FIELD_DECL that was the ultimate source of the decl. */ #define DECL_ORIGINAL_FIELD(NODE) \ ! (tree) DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE)) /* In a FIELD_DECL corresponding to a discriminant, contains the discriminant number. */ --- 256,271 ---- memory. Used when a scalar constant is aliased or has its address taken. */ #define DECL_CONST_CORRESPONDING_VAR(NODE) \ ! (&DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE))->t.generic) ! #define SET_DECL_CONST_CORRESPONDING_VAR(NODE, X) \ ! (DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE)) = (struct lang_decl *)(X)) /* In a FIELD_DECL, points to the FIELD_DECL that was the ultimate source of the decl. */ #define DECL_ORIGINAL_FIELD(NODE) \ ! (&DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE))->t.generic) ! #define SET_DECL_ORIGINAL_FIELD(NODE, X) \ ! (DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE)) = (struct lang_decl *)(X)) /* In a FIELD_DECL corresponding to a discriminant, contains the discriminant number. */ *************** enum gnat_tree_code { *** 229,232 **** /* 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) (TREE_CHECK (NODE, GNAT_LOOP_ID)->real_cst.rtl) --- 273,277 ---- /* 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) diff -Nrc3pad gcc-3.2.3/gcc/ada/a-decima.adb gcc-3.3/gcc/ada/a-decima.adb *** gcc-3.2.3/gcc/ada/a-decima.adb 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-decima.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-decima.ads gcc-3.3/gcc/ada/a-decima.ads *** gcc-3.2.3/gcc/ada/a-decima.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-decima.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-diocst.adb gcc-3.3/gcc/ada/a-diocst.adb *** gcc-3.2.3/gcc/ada/a-diocst.adb 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-diocst.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-diocst.ads gcc-3.3/gcc/ada/a-diocst.ads *** gcc-3.2.3/gcc/ada/a-diocst.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-diocst.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-direio.adb gcc-3.3/gcc/ada/a-direio.adb *** gcc-3.2.3/gcc/ada/a-direio.adb 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-direio.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-direio.ads gcc-3.3/gcc/ada/a-direio.ads *** gcc-3.2.3/gcc/ada/a-direio.ads 2002-05-04 03:27:20.000000000 +0000 --- gcc-3.3/gcc/ada/a-direio.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-dynpri.adb gcc-3.3/gcc/ada/a-dynpri.adb *** gcc-3.2.3/gcc/ada/a-dynpri.adb 2001-10-02 13:51:51.000000000 +0000 --- gcc-3.3/gcc/ada/a-dynpri.adb 2002-10-28 16:19:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- ! -- 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) 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** with Ada.Exceptions; *** 56,65 **** --- 54,69 ---- with System.Tasking.Initialization; -- used for Defer/Undefer_Abort + with System.Parameters; + -- used for Single_Lock + with Unchecked_Conversion; package body Ada.Dynamic_Priorities is + package STPO renames System.Task_Primitives.Operations; + + use System.Parameters; use System.Tasking; use Ada.Exceptions; *************** package body Ada.Dynamic_Priorities is *** 107,113 **** Ada.Task_Identification.Current_Task) is Target : constant Task_ID := Convert_Ids (T); ! Self_ID : constant Task_ID := System.Task_Primitives.Operations.Self; Error_Message : constant String := "Trying to set the priority of a "; begin --- 111,117 ---- Ada.Task_Identification.Current_Task) is Target : constant Task_ID := Convert_Ids (T); ! Self_ID : constant Task_ID := STPO.Self; Error_Message : constant String := "Trying to set the priority of a "; begin *************** package body Ada.Dynamic_Priorities is *** 121,154 **** Error_Message & "terminated task"); end if; ! System.Tasking.Initialization.Defer_Abort (Self_ID); ! System.Task_Primitives.Operations.Write_Lock (Target); if Self_ID = Target then Target.Common.Base_Priority := Priority; ! System.Task_Primitives.Operations.Set_Priority (Target, Priority); ! System.Task_Primitives.Operations.Unlock (Target); ! System.Task_Primitives.Operations.Yield; -- Yield is needed to enforce FIFO task dispatching. -- LL Set_Priority is made while holding the RTS lock so that -- it is inheriting high priority until it release all the RTS -- locks. -- If this is used in a system where Ceiling Locking is -- not enforced we may end up getting two Yield effects. else Target.New_Base_Priority := Priority; Target.Pending_Priority_Change := True; Target.Pending_Action := True; ! System.Task_Primitives.Operations.Wakeup ! (Target, Target.Common.State); -- If the task is suspended, wake it up to perform the change. -- check for ceiling violations ??? - System.Task_Primitives.Operations.Unlock (Target); end if; - System.Tasking.Initialization.Undefer_Abort (Self_ID); end Set_Priority; end Ada.Dynamic_Priorities; --- 125,173 ---- Error_Message & "terminated task"); end if; ! Initialization.Defer_Abort (Self_ID); ! ! if Single_Lock then ! STPO.Lock_RTS; ! end if; ! ! STPO.Write_Lock (Target); if Self_ID = Target then Target.Common.Base_Priority := Priority; ! STPO.Set_Priority (Target, Priority); ! ! STPO.Unlock (Target); ! ! if Single_Lock then ! STPO.Unlock_RTS; ! end if; ! ! STPO.Yield; -- Yield is needed to enforce FIFO task dispatching. -- LL Set_Priority is made while holding the RTS lock so that -- it is inheriting high priority until it release all the RTS -- locks. -- If this is used in a system where Ceiling Locking is -- not enforced we may end up getting two Yield effects. + else Target.New_Base_Priority := Priority; Target.Pending_Priority_Change := True; Target.Pending_Action := True; ! STPO.Wakeup (Target, Target.Common.State); -- If the task is suspended, wake it up to perform the change. -- check for ceiling violations ??? + STPO.Unlock (Target); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end if; + Initialization.Undefer_Abort (Self_ID); end Set_Priority; end Ada.Dynamic_Priorities; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-dynpri.ads gcc-3.3/gcc/ada/a-dynpri.ads *** gcc-3.2.3/gcc/ada/a-dynpri.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-dynpri.ads 2002-03-14 10:58:48.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-einuoc.adb gcc-3.3/gcc/ada/a-einuoc.adb *** gcc-3.2.3/gcc/ada/a-einuoc.adb 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-einuoc.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-einuoc.ads gcc-3.3/gcc/ada/a-einuoc.ads *** gcc-3.2.3/gcc/ada/a-einuoc.ads 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-einuoc.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-except.adb gcc-3.3/gcc/ada/a-except.adb *** gcc-3.2.3/gcc/ada/a-except.adb 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-except.adb 2003-03-04 20:11:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Ada.Exceptions is *** 89,97 **** --- 88,206 ---- -- 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 -- ----------------------- *************** package body Ada.Exceptions is *** 106,135 **** procedure ZZZ; -- Mark end of procedures in this package - Address_Image_Length : constant := - 13 + 10 * Boolean'Pos (Standard'Address_Size > 32); - -- Length of string returned by Address_Image function - 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 Free is new Ada.Unchecked_Deallocation (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr); procedure Raise_Current_Excep (E : Exception_Id); pragma No_Return (Raise_Current_Excep); pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); ! -- 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). ! -- The parameter E is ignored. -- -- This external name for Raise_Current_Excep is historical, and probably ! -- should be changed but for now we keep it, because gdb knows about it. ! -- The parameter is also present for historical compatibility. ??? procedure Raise_Exception_No_Defer (E : Exception_Id; Message : String := ""); --- 215,283 ---- 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); pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); ! -- This is a simple wrapper to Process_Raise_Exception setting the ! -- From_Signal_Handler argument to False. -- -- This external name for Raise_Current_Excep is historical, and probably ! -- should be changed but for now we keep it, because gdb and gigi know ! -- about it. procedure Raise_Exception_No_Defer (E : Exception_Id; Message : String := ""); *************** package body Ada.Exceptions is *** 148,178 **** procedure Raise_With_Location (E : Exception_Id; ! F : SSL.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_Constraint_Error ! (File : SSL.Big_String_Ptr; Line : Integer); pragma No_Return (Raise_Constraint_Error); ! pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); -- Raise constraint error with file:line information procedure Raise_Program_Error ! (File : SSL.Big_String_Ptr; Line : Integer); pragma No_Return (Raise_Program_Error); ! pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error"); -- Raise program error with file:line information procedure Raise_Storage_Error ! (File : SSL.Big_String_Ptr; Line : Integer); pragma No_Return (Raise_Storage_Error); ! pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error"); -- Raise storage error with file:line information -- The exception raising process and the automatic tracing mechanism rely -- on some careful use of flags attached to the exception occurrence. The -- graph below illustrates the relations between the Raise_ subprograms --- 296,369 ---- 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; ! Line : Integer); pragma No_Return (Raise_Constraint_Error); ! pragma Export ! (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); -- Raise constraint error with file:line information + procedure Raise_Constraint_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr); + pragma No_Return (Raise_Constraint_Error_Msg); + pragma Export + (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); + -- Raise constraint error with file:line + msg information + procedure Raise_Program_Error ! (File : Big_String_Ptr; ! Line : Integer); pragma No_Return (Raise_Program_Error); ! pragma Export ! (C, Raise_Program_Error, "__gnat_raise_program_error"); -- Raise program error with file:line information + procedure Raise_Program_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr); + pragma No_Return (Raise_Program_Error_Msg); + pragma Export + (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); + -- Raise program error with file:line + msg information + procedure Raise_Storage_Error ! (File : Big_String_Ptr; ! Line : Integer); pragma No_Return (Raise_Storage_Error); ! pragma Export ! (C, Raise_Storage_Error, "__gnat_raise_storage_error"); -- Raise storage error with file:line information + procedure Raise_Storage_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr); + pragma No_Return (Raise_Storage_Error_Msg); + pragma Export + (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); + -- Raise storage error with file:line + reason msg information + -- The exception raising process and the automatic tracing mechanism rely -- on some careful use of flags attached to the exception occurrence. The -- graph below illustrates the relations between the Raise_ subprograms *************** package body Ada.Exceptions is *** 211,222 **** procedure Set_Exception_C_Msg (Id : Exception_Id; ! Msg : SSL.Big_String_Ptr; ! Line : Integer := 0); -- 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. Msg is a null terminated string. when Line > 0, ! -- Msg is the filename and line the line number of the exception location. procedure To_Stderr (S : String); pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); --- 402,417 ---- 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"); *************** package body Ada.Exceptions is *** 261,266 **** --- 456,719 ---- -- which are somewhat redundant is historical. Notify_Exception -- certainly is complete enough, but GDB still uses this routine. + ----------------------------- + -- Run-Time Check Routines -- + ----------------------------- + + -- These routines are called from the runtime to raise a specific + -- exception with a reason message attached. The parameters are + -- the file name and line number in each case. The names are keyed + -- to the codes defined in Types.ads and a-types.h (for example, + -- the name Rcheck_05 refers to the Reason whose Pos code is 5). + + procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer); + + pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); + pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); + pragma Export (C, Rcheck_02, "__gnat_rcheck_02"); + pragma Export (C, Rcheck_03, "__gnat_rcheck_03"); + pragma Export (C, Rcheck_04, "__gnat_rcheck_04"); + pragma Export (C, Rcheck_05, "__gnat_rcheck_05"); + pragma Export (C, Rcheck_06, "__gnat_rcheck_06"); + pragma Export (C, Rcheck_07, "__gnat_rcheck_07"); + pragma Export (C, Rcheck_08, "__gnat_rcheck_08"); + pragma Export (C, Rcheck_09, "__gnat_rcheck_09"); + pragma Export (C, Rcheck_10, "__gnat_rcheck_10"); + pragma Export (C, Rcheck_11, "__gnat_rcheck_11"); + pragma Export (C, Rcheck_12, "__gnat_rcheck_12"); + pragma Export (C, Rcheck_13, "__gnat_rcheck_13"); + pragma Export (C, Rcheck_14, "__gnat_rcheck_14"); + pragma Export (C, Rcheck_15, "__gnat_rcheck_15"); + pragma Export (C, Rcheck_16, "__gnat_rcheck_16"); + pragma Export (C, Rcheck_17, "__gnat_rcheck_17"); + pragma Export (C, Rcheck_18, "__gnat_rcheck_18"); + pragma Export (C, Rcheck_19, "__gnat_rcheck_19"); + pragma Export (C, Rcheck_20, "__gnat_rcheck_20"); + pragma Export (C, Rcheck_21, "__gnat_rcheck_21"); + pragma Export (C, Rcheck_22, "__gnat_rcheck_22"); + pragma Export (C, Rcheck_23, "__gnat_rcheck_23"); + pragma Export (C, Rcheck_24, "__gnat_rcheck_24"); + pragma Export (C, Rcheck_25, "__gnat_rcheck_25"); + pragma Export (C, Rcheck_26, "__gnat_rcheck_26"); + pragma Export (C, Rcheck_27, "__gnat_rcheck_27"); + pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); + + --------------------------------------------- + -- Reason Strings for Run-Time Check Calls -- + --------------------------------------------- + + -- These strings are null-terminated and are used by Rcheck_nn. The + -- strings correspond to the definitions for Types.RT_Exception_Code. + + use ASCII; + + Rmsg_00 : constant String := "access check failed" & NUL; + Rmsg_01 : constant String := "access parameter is null" & NUL; + Rmsg_02 : constant String := "discriminant check failed" & NUL; + Rmsg_03 : constant String := "divide by zero" & NUL; + Rmsg_04 : constant String := "explicit raise" & NUL; + Rmsg_05 : constant String := "index check failed" & NUL; + Rmsg_06 : constant String := "invalid data" & NUL; + Rmsg_07 : constant String := "length check failed" & NUL; + Rmsg_08 : constant String := "overflow check failed" & NUL; + Rmsg_09 : constant String := "partition check failed" & NUL; + Rmsg_10 : constant String := "range check failed" & NUL; + Rmsg_11 : constant String := "tag check failed" & NUL; + Rmsg_12 : constant String := "access before elaboration" & NUL; + Rmsg_13 : constant String := "accessibility check failed" & NUL; + 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; + Rmsg_24 : constant String := "empty storage pool" & NUL; + Rmsg_25 : constant String := "explicit raise" & NUL; + Rmsg_26 : constant String := "infinite recursion" & NUL; + 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 -- --------------------------------------- *************** package body Ada.Exceptions is *** 307,324 **** (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 CR/LF couple 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 : --- 760,777 ---- (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 : *************** package body Ada.Exceptions is *** 408,429 **** procedure Unhandled_Terminate; pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); - procedure Propagate_Exception (Mstate : Machine_State); - 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. M is - -- the initial machine state, representing the site of the exception - -- raise operation. Propagate_Exception searches the exception tables - -- for an applicable handler, calling Pop_Frame as needed. If and when - -- it locates an applicable handler Propagate_Exception makes a call - -- to Enter_Handler to actually enter the handler. If the search is - -- unable to locate an applicable handler, execution is terminated by - -- calling Unhandled_Exception_Terminate. - - procedure Call_Chain (Excep : EOA); - -- Store up to Max_Tracebacks in Excep, corresponding to the current - -- call chain. - ----------------------- -- Polling Interface -- ----------------------- --- 861,866 ---- *************** package body Ada.Exceptions is *** 504,511 **** is begin Ptr := Ptr + 1; - Info (Ptr) := ASCII.CR; - Ptr := Ptr + 1; Info (Ptr) := ASCII.LF; end Append_Info_NL; --- 941,946 ---- *************** package body Ada.Exceptions is *** 823,833 **** return Name (P .. Name'Length); end Exception_Name_Simple; ! ------------------------- ! -- Propagate_Exception -- ! ------------------------- ! procedure Propagate_Exception (Mstate : Machine_State) is Excep : constant EOA := Get_Current_Excep.all; Loc : Code_Loc; Lo, Hi : Natural; --- 1258,1355 ---- return Name (P .. Name'Length); end Exception_Name_Simple; ! ----------------------------- ! -- Process_Raise_Exception -- ! ----------------------------- ! procedure Process_Raise_Exception ! (E : Exception_Id; ! From_Signal_Handler : Boolean) ! is ! pragma Inspection_Point (E); ! -- 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 ! -- WARNING : There should be no exception handler for this body ! -- because this would cause gigi to prepend a setup for a new ! -- jmpbuf to the sequence of statements. We would then always get ! -- this new buf in Jumpbuf_Ptr instead of the one for the exception ! -- we are handling, which would completely break the whole design ! -- of this procedure. ! ! -- Processing varies between zero cost and setjmp/lonjmp processing. ! ! 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 ! -- means that we have no finalizations to do other than at the outer ! -- level). Perform the necessary notification tasks in both cases. ! ! if Jumpbuf_Ptr /= Null_Address then ! ! 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; *************** package body Ada.Exceptions is *** 872,881 **** FH_Mstate : aliased Machine_State_Record; -- Records the machine state for the finalization handler ! FH_Handler : Code_Loc; -- Record handler address for finalization handler ! FH_Num_Trb : Natural; -- Save number of tracebacks for finalization handler begin --- 1394,1403 ---- 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 *************** package body Ada.Exceptions is *** 1034,1108 **** Unhandled_Exception_Terminate; ! end Propagate_Exception; ! ! ------------------------- ! -- Raise_Current_Excep -- ! ------------------------- ! ! procedure Raise_Current_Excep (E : Exception_Id) is ! pragma Inspection_Point (E); ! -- 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; begin ! -- WARNING : There should be no exception handler for this body ! -- because this would cause gigi to prepend a setup for a new ! -- jmpbuf to the sequence of statements. We would then always get ! -- this new buf in Jumpbuf_Ptr instead of the one for the exception ! -- we are handling, which would completely break the whole design ! -- of this procedure. ! -- If the jump buffer pointer is non-null, it means that a jump ! -- buffer was allocated (obviously that happens only in the case ! -- of zero cost exceptions not implemented, or if a jump buffer ! -- was manually set up by C code). ! if Jumpbuf_Ptr /= Null_Address then ! Excep := Get_Current_Excep.all; ! if Exception_Tracebacks /= 0 then ! Call_Chain (Excep); ! end if; ! -- Perform the necessary notification tasks if this is not a ! -- reraise. Actually ask to skip the low level debugger notification ! -- call since we do not have the necessary information to "feed" ! -- it properly. ! if not Excep.Exception_Raised then ! Excep.Exception_Raised := True; ! Notify_Handled_Exception (Null_Loc, False, False); ! end if; ! builtin_longjmp (Jumpbuf_Ptr, 1); ! -- If we have no jump buffer, then either zero cost exception ! -- handling is in place, or we have no handlers anyway. In ! -- either case we have an unhandled exception. If zero cost ! -- exception handling is in place, propagate the exception ! elsif Subprogram_Descriptors /= null then ! Set_Machine_State (Mstate_Ptr); ! Propagate_Exception (Mstate_Ptr); ! -- Otherwise, we know the exception is unhandled by the absence ! -- of an allocated jump buffer. Note that this means that we also ! -- have no finalizations to do other than at the outer level. ! else ! if Exception_Tracebacks /= 0 then ! Call_Chain (Get_Current_Excep.all); ! end if; ! Notify_Unhandled_Exception (E); ! Unhandled_Exception_Terminate; end if; end Raise_Current_Excep; --------------------- --- 1556,1666 ---- 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 -- + ---------------------------- + + procedure Raise_Constraint_Error + (File : Big_String_Ptr; + Line : Integer) + is + begin + Raise_With_Location (Constraint_Error_Def'Access, File, Line); + end Raise_Constraint_Error; + + -------------------------------- + -- Raise_Constraint_Error_Msg -- + -------------------------------- + + procedure Raise_Constraint_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr) + is + begin + Raise_With_Location_And_Msg + (Constraint_Error_Def'Access, File, Line, Msg); + end Raise_Constraint_Error_Msg; + + ------------------------- + -- Raise_Current_Excep -- + ------------------------- + + procedure Raise_Current_Excep (E : Exception_Id) is + begin + Process_Raise_Exception (E => E, From_Signal_Handler => False); end Raise_Current_Excep; --------------------- *************** package body Ada.Exceptions is *** 1150,1200 **** procedure Raise_From_Signal_Handler (E : Exception_Id; ! M : SSL.Big_String_Ptr) is - Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; - Mstate_Ptr : constant Machine_State := - Machine_State (Get_Machine_State_Addr.all); - begin Set_Exception_C_Msg (E, M); Abort_Defer.all; ! ! -- Now we raise the exception. The following code is essentially ! -- identical to the Raise_Current_Excep routine, except that in the ! -- zero cost exception case, we do not call Set_Machine_State, since ! -- the signal handler that passed control here has already set the ! -- machine state directly. ! -- ! -- We also do not compute the backtrace for the occurrence since going ! -- through the signal handler is far from trivial and it is not a ! -- problem to fail providing a backtrace in the "raised from signal ! -- handler" case. ! ! -- If the jump buffer pointer is non-null, it means that a jump ! -- buffer was allocated (obviously that happens only in the case ! -- of zero cost exceptions not implemented, or if a jump buffer ! -- was manually set up by C code). ! ! if Jumpbuf_Ptr /= Null_Address then ! builtin_longjmp (Jumpbuf_Ptr, 1); ! ! -- If we have no jump buffer, then either zero cost exception ! -- handling is in place, or we have no handlers anyway. In ! -- either case we have an unhandled exception. If zero cost ! -- exception handling is in place, propagate the exception ! ! elsif Subprogram_Descriptors /= null then ! Propagate_Exception (Mstate_Ptr); ! ! -- Otherwise, we know the exception is unhandled by the absence ! -- of an allocated jump buffer. Note that this means that we also ! -- have no finalizations to do other than at the outer level. ! ! else ! Notify_Unhandled_Exception (E); ! Unhandled_Exception_Terminate; ! end if; end Raise_From_Signal_Handler; ------------------ --- 1708,1719 ---- procedure Raise_From_Signal_Handler (E : Exception_Id; ! 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; ------------------ *************** package body Ada.Exceptions is *** 1210,1271 **** end Raise_No_Msg; ------------------------- - -- Raise_With_Location -- - ------------------------- - - procedure Raise_With_Location - (E : Exception_Id; - F : SSL.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_Constraint_Error -- - ---------------------------- - - procedure Raise_Constraint_Error - (File : SSL.Big_String_Ptr; Line : Integer) is - begin - Raise_With_Location (Constraint_Error_Def'Access, File, Line); - end Raise_Constraint_Error; - - ------------------------- -- Raise_Program_Error -- ------------------------- procedure Raise_Program_Error ! (File : SSL.Big_String_Ptr; Line : Integer) is begin Raise_With_Location (Program_Error_Def'Access, File, Line); end Raise_Program_Error; ------------------------- -- Raise_Storage_Error -- ------------------------- procedure Raise_Storage_Error ! (File : SSL.Big_String_Ptr; Line : Integer) is begin Raise_With_Location (Storage_Error_Def'Access, File, Line); end Raise_Storage_Error; ---------------------- -- Raise_With_C_Msg -- ---------------------- procedure Raise_With_C_Msg ! (E : Exception_Id; ! M : SSL.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_Msg -- -------------------- --- 1729,1830 ---- end Raise_No_Msg; ------------------------- -- Raise_Program_Error -- ------------------------- procedure Raise_Program_Error ! (File : Big_String_Ptr; ! Line : Integer) ! is begin Raise_With_Location (Program_Error_Def'Access, File, Line); end Raise_Program_Error; + ----------------------------- + -- Raise_Program_Error_Msg -- + ----------------------------- + + procedure Raise_Program_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr) + is + begin + Raise_With_Location_And_Msg + (Program_Error_Def'Access, File, Line, Msg); + end Raise_Program_Error_Msg; + ------------------------- -- Raise_Storage_Error -- ------------------------- procedure Raise_Storage_Error ! (File : Big_String_Ptr; ! Line : Integer) ! is begin Raise_With_Location (Storage_Error_Def'Access, File, Line); end Raise_Storage_Error; + ----------------------------- + -- Raise_Storage_Error_Msg -- + ----------------------------- + + procedure Raise_Storage_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr) + is + begin + Raise_With_Location_And_Msg + (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 -- + --------------------------------- + + procedure Raise_With_Location_And_Msg + (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; + -------------------- -- Raise_With_Msg -- -------------------- *************** package body Ada.Exceptions is *** 1513,1525 **** procedure Set_Exception_C_Msg (Id : Exception_Id; ! Msg : Big_String_Ptr; ! Line : Integer := 0) is Excep : constant EOA := Get_Current_Excep.all; Val : Integer := Line; Remind : Integer; Size : Integer := 1; begin Excep.Exception_Raised := False; --- 2072,2086 ---- 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; *************** package body Ada.Exceptions is *** 1529,1542 **** Excep.Msg_Length := 0; Excep.Cleanup_Flag := False; ! while Msg (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) := Msg (Excep.Msg_Length); end loop; if Line > 0 then -- Compute the number of needed characters while Val > 0 loop --- 2090,2106 ---- 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 *************** package body Ada.Exceptions is *** 1561,1566 **** --- 2125,2148 ---- 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; ------------------- *************** package body Ada.Exceptions is *** 1593,1599 **** procedure Next_String; -- On entry, To points to last character of previous line of the ! -- message, terminated by CR/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 --- 2175,2181 ---- 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 *************** package body Ada.Exceptions is *** 1605,1619 **** procedure Next_String is begin ! From := To + 3; if From < S'Last then To := From + 1; ! while To < S'Last - 2 loop if To >= S'Last then Bad_EO; ! elsif S (To + 1) = ASCII.CR then exit; else To := To + 1; --- 2187,2201 ---- 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; *************** package body Ada.Exceptions is *** 1631,1637 **** else X.Cleanup_Flag := False; ! To := S'First - 3; Next_String; if S (From .. From + 15) /= "Exception name: " then --- 2213,2219 ---- else X.Cleanup_Flag := False; ! To := S'First - 2; Next_String; if S (From .. From + 15) /= "Exception name: " then *************** package body Ada.Exceptions is *** 1885,1892 **** type int is new Integer; procedure Unhandled_Exception_Terminate is ! Excep : constant EOA := Get_Current_Excep.all; ! Msg : constant String := Exception_Message (Excep.all); -- Start of processing for Unhandled_Exception_Terminate --- 2467,2480 ---- 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 diff -Nrc3pad gcc-3.2.3/gcc/ada/a-except.ads gcc-3.3/gcc/ada/a-except.ads *** gcc-3.2.3/gcc/ada/a-except.ads 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-except.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 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 -- *************** package Ada.Exceptions is *** 85,91 **** -- PID=nnnn -- 0xyyyyyyyy 0xyyyyyyyy ... -- ! -- The lines are separated by an ASCII.CR/ASCII.LF sequence. -- 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. --- 84,90 ---- -- 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. *************** package Ada.Exceptions is *** 100,106 **** function Save_Occurrence (Source : Exception_Occurrence) ! return Exception_Occurrence_Access; private package SSL renames System.Standard_Library; --- 99,105 ---- function Save_Occurrence (Source : Exception_Occurrence) ! return Exception_Occurrence_Access; private package SSL renames System.Standard_Library; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-excpol.adb gcc-3.3/gcc/ada/a-excpol.adb *** gcc-3.2.3/gcc/ada/a-excpol.adb 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-excpol.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (dummy version where polling is not used) -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-exctra.adb gcc-3.3/gcc/ada/a-exctra.adb *** gcc-3.2.3/gcc/ada/a-exctra.adb 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-exctra.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-exctra.ads gcc-3.3/gcc/ada/a-exctra.ads *** gcc-3.2.3/gcc/ada/a-exctra.ads 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-exctra.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-filico.adb gcc-3.3/gcc/ada/a-filico.adb *** gcc-3.2.3/gcc/ada/a-filico.adb 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-filico.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-filico.ads gcc-3.3/gcc/ada/a-filico.ads *** gcc-3.2.3/gcc/ada/a-filico.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-filico.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-finali.adb gcc-3.3/gcc/ada/a-finali.adb *** gcc-3.2.3/gcc/ada/a-finali.adb 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-finali.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Ada.Finalization is *** 51,56 **** --- 50,57 ---- ------------ procedure Adjust (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin null; end Adjust; *************** package body Ada.Finalization is *** 60,70 **** --- 61,75 ---- -------------- procedure Finalize (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin null; end Finalize; procedure Finalize (Object : in out Limited_Controlled) is + pragma Warnings (Off, Object); + begin null; end Finalize; *************** package body Ada.Finalization is *** 74,84 **** --- 79,93 ---- ---------------- procedure Initialize (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin null; end Initialize; procedure Initialize (Object : in out Limited_Controlled) is + pragma Warnings (Off, Object); + begin null; end Initialize; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-finali.ads gcc-3.3/gcc/ada/a-finali.ads *** gcc-3.2.3/gcc/ada/a-finali.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-finali.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-flteio.ads gcc-3.3/gcc/ada/a-flteio.ads *** gcc-3.2.3/gcc/ada/a-flteio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-flteio.ads 2002-03-14 10:58:48.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-fwteio.ads gcc-3.3/gcc/ada/a-fwteio.ads *** gcc-3.2.3/gcc/ada/a-fwteio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-fwteio.ads 2002-03-14 10:58:48.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-inteio.ads gcc-3.3/gcc/ada/a-inteio.ads *** gcc-3.2.3/gcc/ada/a-inteio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-inteio.ads 2002-03-14 10:58:48.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-interr.adb gcc-3.3/gcc/ada/a-interr.adb *** gcc-3.2.3/gcc/ada/a-interr.adb 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-interr.adb 2002-03-14 10:58:48.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-interr.ads gcc-3.3/gcc/ada/a-interr.ads *** gcc-3.2.3/gcc/ada/a-interr.ads 2002-05-04 03:27:21.000000000 +0000 --- gcc-3.3/gcc/ada/a-interr.ads 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-intnam.ads gcc-3.3/gcc/ada/a-intnam.ads *** gcc-3.2.3/gcc/ada/a-intnam.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-intnam.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-intsig.adb gcc-3.3/gcc/ada/a-intsig.adb *** gcc-3.2.3/gcc/ada/a-intsig.adb 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-intsig.adb 2002-10-23 07:33:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-intsig.ads gcc-3.3/gcc/ada/a-intsig.ads *** gcc-3.2.3/gcc/ada/a-intsig.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-intsig.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ioexce.ads gcc-3.3/gcc/ada/a-ioexce.ads *** gcc-3.2.3/gcc/ada/a-ioexce.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-ioexce.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-iwteio.ads gcc-3.3/gcc/ada/a-iwteio.ads *** gcc-3.2.3/gcc/ada/a-iwteio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-iwteio.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-lfteio.ads gcc-3.3/gcc/ada/a-lfteio.ads *** gcc-3.2.3/gcc/ada/a-lfteio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-lfteio.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-lfwtio.ads gcc-3.3/gcc/ada/a-lfwtio.ads *** gcc-3.2.3/gcc/ada/a-lfwtio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-lfwtio.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/ali.adb gcc-3.3/gcc/ada/ali.adb *** gcc-3.2.3/gcc/ada/ali.adb 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/ali.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.6.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body ALI is *** 127,140 **** 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). The ! -- name is adjusted appropriately if it refers to a file that is to be ! -- substituted by another name as a result of a configuration pragma. ! -- If Lower is set to true then the Name_Buffer will be converted to ! -- all lower case. This only happends for systems where file names are ! -- not case sensitive, and ensures that gnatbind works correctly on ! -- such systems, regardless of the case of the file name. Note that ! -- a name can be terminated by a right typeref bracket or '='. function Get_Nat return Nat; -- Skip blanks, then scan out an unsigned integer value in Nat range --- 126,139 ---- 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 *************** package body ALI is *** 305,315 **** loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; ! exit when At_End_Of_Field ! or else Nextc = ')' ! or else Nextc = '}' ! or else Nextc = '>' ! or else Nextc = '='; end loop; -- Convert file name to all lower case if file names are not case --- 304,322 ---- loop 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 = '>' ! or else Nextc = '='; ! end if; end loop; -- Convert file name to all lower case if file names are not case *************** package body ALI is *** 639,652 **** Checkc (' '); Skip_Space; ! for J in Partition_Restrictions loop C := Getc; ! if C = 'v' or else C = 'r' or else C = 'n' then ! ALIs.Table (Id).Restrictions (J) := C; ! else ! Fatal_Error; ! end if; end loop; if At_Eol then --- 646,670 ---- Checkc (' '); Skip_Space; ! for J in All_Restrictions loop C := Getc; + ALIs.Table (Id).Restrictions (J) := C; ! case C is ! when 'v' => ! Restrictions (J) := 'v'; ! ! when 'r' => ! if Restrictions (J) = 'n' then ! Restrictions (J) := 'r'; ! end if; ! ! when 'n' => ! null; ! ! when others => ! Fatal_Error; ! end case; end loop; if At_Eol then *************** package body ALI is *** 694,699 **** --- 712,719 ---- if Debug_Flag_U then Write_Str (" ----> reading unit "); + Write_Int (Int (Units.Last)); + Write_Str (" "); Write_Unit_Name (Units.Table (Units.Last).Uname); Write_Str (" from file "); Write_Name (Units.Table (Units.Last).Sfile); *************** package body ALI is *** 710,724 **** and then Units.Table (Units.Last).Sfile /= Units.Table (Unit_Id (Info)).Sfile then ! -- If Err is set then treat duplicate unit name as an instance ! -- of a bad ALI format. This is the case of being called from ! -- gnatmake, and the point is that if anything is wrong with ! -- the ALI file, then gnatmake should just recompile. if Err then ! raise Bad_ALI_Format; ! -- If Err is not set, then this is a fatal error else Set_Standard_Error; --- 730,751 ---- and then Units.Table (Units.Last).Sfile /= Units.Table (Unit_Id (Info)).Sfile then ! -- If Err is set then ignore duplicate unit name. This is the ! -- case of a call from gnatmake, where the situation can arise ! -- from substitution of source files. In such situations, the ! -- processing in gnatmake will always result in any required ! -- recompilations in any case, and if we consider this to be ! -- an error we get strange cases (for example when a generic ! -- instantiation is replaced by a normal package) where we ! -- read the old ali file, decide to recompile, and then decide ! -- that the old and new ali files are incompatible. if Err then ! null; ! -- If Err is not set, then this is a fatal error. This is ! -- the case of being called from the binder, where we must ! -- definitely diagnose this as an error. else Set_Standard_Error; *************** package body ALI is *** 991,1098 **** Units.Table (Units.Last).Last_With := Withs.Last; Units.Table (Units.Last).Last_Arg := Args.Last; ! end loop Unit_Loop; ! ! -- End loop through units for one ALI file ! ALIs.Table (Id).Last_Unit := Units.Last; ! ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; ! -- Set types of the units (there can be at most 2 of them) ! if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then ! Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; ! Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; ! else ! -- Deal with body only and spec only cases, note that the reason we ! -- do our own checking of the name (rather than using Is_Body_Name) ! -- is that Uname drags in far too much compiler junk! ! Get_Name_String (Units.Table (Units.Last).Uname); ! if Name_Buffer (Name_Len) = 'b' then ! Units.Table (Units.Last).Utype := Is_Body_Only; ! else ! Units.Table (Units.Last).Utype := Is_Spec_Only; ! end if; ! end if; ! -- If there are linker options lines present, scan them ! while C = 'L' loop ! Checkc (' '); ! Skip_Space; ! Checkc ('"'); ! Name_Len := 0; ! 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; ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last).Name ! := Name_Enter; ! Linker_Options.Table (Linker_Options.Last).Unit ! := ALIs.Table (Id).First_Unit; ! Linker_Options.Table (Linker_Options.Last).Internal_File ! := Is_Internal_File_Name (F); ! Linker_Options.Table (Linker_Options.Last).Original_Pos ! := Linker_Options.Last; ! end loop; -- Scan out external version references and put in hash table --- 1018,1128 ---- Units.Table (Units.Last).Last_With := Withs.Last; Units.Table (Units.Last).Last_Arg := Args.Last; ! -- If there are linker options lines present, scan them ! 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; ! Linker_Options.Table (Linker_Options.Last).Name := ! Name_Enter; ! Linker_Options.Table (Linker_Options.Last).Unit := ! Units.Last; ! Linker_Options.Table (Linker_Options.Last).Internal_File := ! Is_Internal_File_Name (F); ! Linker_Options.Table (Linker_Options.Last).Original_Pos := ! Linker_Options.Last; ! end if; ! end loop Unit_Loop; ! -- End loop through units for one ALI file ! ALIs.Table (Id).Last_Unit := Units.Last; ! ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; ! -- Set types of the units (there can be at most 2 of them) ! if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then ! Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; ! Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; ! else ! -- Deal with body only and spec only cases, note that the reason we ! -- do our own checking of the name (rather than using Is_Body_Name) ! -- is that Uname drags in far too much compiler junk! ! Get_Name_String (Units.Table (Units.Last).Uname); ! ! if Name_Buffer (Name_Len) = 'b' then ! Units.Table (Units.Last).Utype := Is_Body_Only; ! else ! Units.Table (Units.Last).Utype := Is_Spec_Only; ! end if; ! end if; -- Scan out external version references and put in hash table diff -Nrc3pad gcc-3.2.3/gcc/ada/ali.ads gcc-3.3/gcc/ada/ali.ads *** gcc-3.2.3/gcc/ada/ali.ads 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/ali.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.6.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package ALI is *** 81,87 **** type Main_Program_Type is (None, Proc, Func); -- Indicator of whether unit can be used as main program ! type Restrictions_String is array (Partition_Restrictions) of Character; -- Type used to hold string from R line type ALIs_Record is record --- 80,86 ---- type Main_Program_Type is (None, Proc, Func); -- Indicator of whether unit can be used as main program ! type Restrictions_String is array (All_Restrictions) of Character; -- Type used to hold string from R line type ALIs_Record is record *************** package ALI is *** 363,368 **** --- 362,373 ---- -- 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. + Restrictions : Restrictions_String := (others => 'n'); + -- This array records the cumulative contributions of R lines in all + -- ali files. An entry is changed will be set to v if any ali file + -- indicates that the restriction is violated, and otherwise will be + -- set to r if the restriction is specified by some unit. + Static_Elaboration_Model_Used : Boolean := False; -- Set to False by Initialize_ALI. Set to True if any ALI file for a -- non-internal unit compiled with the static elaboration model is *************** package ALI is *** 447,463 **** -- Linker_Options Table -- -------------------------- ! -- Each unique linker option (L line) in an ALI file generates ! -- an entry in the Linker_Options table. Note that only unique ! -- entries are stored, i.e. if the same entry appears twice, the ! -- second entry is suppressed. Each entry is a character sequence ! -- terminated by a NUL character. type Linker_Option_Record is record ! Name : Name_Id; ! Unit : Unit_Id; Internal_File : Boolean; ! Original_Pos : Positive; end record; -- Declare the Linker_Options Table --- 452,480 ---- -- Linker_Options Table -- -------------------------- ! -- If an ALI file has one of more Linker_Options lines, then a single ! -- entry is made in this table. If more than one Linker_Options lines ! -- appears in a given ALI file, then the arguments are concatenated ! -- to form the entry in this table, using a NUL character as the ! -- separator, and a final NUL character is appended to the end. type Linker_Option_Record is record ! Name : Name_Id; ! -- Name entry containing concatenated list of Linker_Options ! -- arguments separated by NUL and ended by NUL as described above. ! ! Unit : Unit_Id; ! -- Unit_Id for the entry ! Internal_File : Boolean; ! -- Set True if the linker options are from an internal file. This is ! -- used to insert certain standard entries after all the user entries ! -- but before the entries from the run-time. ! ! Original_Pos : Positive; ! -- Keep track of original position in the linker options table. This ! -- is used to implement a stable sort when we sort the linker options ! -- table. end record; -- Declare the Linker_Options Table diff -Nrc3pad gcc-3.2.3/gcc/ada/a-liteio.ads gcc-3.3/gcc/ada/a-liteio.ads *** gcc-3.2.3/gcc/ada/a-liteio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-liteio.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/ali-util.adb gcc-3.3/gcc/ada/ali-util.adb *** gcc-3.2.3/gcc/ada/ali-util.adb 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/ali-util.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Opt; use Opt; *** 32,37 **** --- 31,38 ---- with Osint; use Osint; with System.CRC32; + with System.Memory; + with System.Address_To_Access_Conversions; package body ALI.Util is *************** package body ALI.Util is *** 91,101 **** -- Free source file buffer procedure Free_Source is ! procedure free (Arg : Source_Buffer_Ptr); ! pragma Import (C, free, "free"); begin ! free (Src); end Free_Source; -- Start of processing for Get_File_Checksum --- 92,103 ---- -- 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 diff -Nrc3pad gcc-3.2.3/gcc/ada/ali-util.ads gcc-3.3/gcc/ada/ali-util.ads *** gcc-3.2.3/gcc/ada/ali-util.ads 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/ali-util.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-liwtio.ads gcc-3.3/gcc/ada/a-liwtio.ads *** gcc-3.2.3/gcc/ada/a-liwtio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-liwtio.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-llftio.ads gcc-3.3/gcc/ada/a-llftio.ads *** gcc-3.2.3/gcc/ada/a-llftio.ads 2002-05-07 08:22:05.000000000 +0000 --- gcc-3.3/gcc/ada/a-llftio.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-llfwti.ads gcc-3.3/gcc/ada/a-llfwti.ads *** gcc-3.2.3/gcc/ada/a-llfwti.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-llfwti.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-llitio.ads gcc-3.3/gcc/ada/a-llitio.ads *** gcc-3.2.3/gcc/ada/a-llitio.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-llitio.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-lliwti.ads gcc-3.3/gcc/ada/a-lliwti.ads *** gcc-3.2.3/gcc/ada/a-lliwti.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-lliwti.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/alloc.ads gcc-3.3/gcc/ada/alloc.ads *** gcc-3.2.3/gcc/ada/alloc.ads 2002-05-04 03:27:32.000000000 +0000 --- gcc-3.3/gcc/ada/alloc.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ncelfu.ads gcc-3.3/gcc/ada/a-ncelfu.ads *** gcc-3.2.3/gcc/ada/a-ncelfu.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-ncelfu.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- *************** with Ada.Numerics.Generic_Complex_Elemen *** 21,23 **** --- 20,24 ---- package Ada.Numerics.Complex_Elementary_Functions is new Ada.Numerics.Generic_Complex_Elementary_Functions (Ada.Numerics.Complex_Types); + + pragma Pure (Ada.Numerics.Complex_Elementary_Functions); diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ngcefu.adb gcc-3.3/gcc/ada/a-ngcefu.adb *** gcc-3.2.3/gcc/ada/a-ngcefu.adb 2002-05-04 03:27:22.000000000 +0000 --- gcc-3.3/gcc/ada/a-ngcefu.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ngcefu.ads gcc-3.3/gcc/ada/a-ngcefu.ads *** gcc-3.2.3/gcc/ada/a-ngcefu.ads 2001-10-02 13:51:52.000000000 +0000 --- gcc-3.3/gcc/ada/a-ngcefu.ads 2002-03-14 10:58:49.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ngcoty.adb gcc-3.3/gcc/ada/a-ngcoty.adb *** gcc-3.2.3/gcc/ada/a-ngcoty.adb 2002-05-04 03:27:22.000000000 +0000 --- gcc-3.3/gcc/ada/a-ngcoty.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ngcoty.ads gcc-3.3/gcc/ada/a-ngcoty.ads *** gcc-3.2.3/gcc/ada/a-ngcoty.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-ngcoty.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ngelfu.adb gcc-3.3/gcc/ada/a-ngelfu.adb *** gcc-3.2.3/gcc/ada/a-ngelfu.adb 2002-05-04 03:27:22.000000000 +0000 --- gcc-3.3/gcc/ada/a-ngelfu.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ngelfu.ads gcc-3.3/gcc/ada/a-ngelfu.ads *** gcc-3.2.3/gcc/ada/a-ngelfu.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-ngelfu.ads 2002-03-14 10:58:50.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nlcefu.ads gcc-3.3/gcc/ada/a-nlcefu.ads *** gcc-3.2.3/gcc/ada/a-nlcefu.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nlcefu.ads 2002-03-14 10:58:50.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nlcoty.ads gcc-3.3/gcc/ada/a-nlcoty.ads *** gcc-3.2.3/gcc/ada/a-nlcoty.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nlcoty.ads 2002-03-14 10:58:50.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nlelfu.ads gcc-3.3/gcc/ada/a-nlelfu.ads *** gcc-3.2.3/gcc/ada/a-nlelfu.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nlelfu.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nllcef.ads gcc-3.3/gcc/ada/a-nllcef.ads *** gcc-3.2.3/gcc/ada/a-nllcef.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nllcef.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nllcty.ads gcc-3.3/gcc/ada/a-nllcty.ads *** gcc-3.2.3/gcc/ada/a-nllcty.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nllcty.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nllefu.ads gcc-3.3/gcc/ada/a-nllefu.ads *** gcc-3.2.3/gcc/ada/a-nllefu.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nllefu.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nscefu.ads gcc-3.3/gcc/ada/a-nscefu.ads *** gcc-3.2.3/gcc/ada/a-nscefu.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nscefu.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nscoty.ads gcc-3.3/gcc/ada/a-nscoty.ads *** gcc-3.2.3/gcc/ada/a-nscoty.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nscoty.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nselfu.ads gcc-3.3/gcc/ada/a-nselfu.ads *** gcc-3.2.3/gcc/ada/a-nselfu.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nselfu.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nucoty.ads gcc-3.3/gcc/ada/a-nucoty.ads *** gcc-3.2.3/gcc/ada/a-nucoty.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nucoty.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nudira.adb gcc-3.3/gcc/ada/a-nudira.adb *** gcc-3.2.3/gcc/ada/a-nudira.adb 2002-05-04 03:27:22.000000000 +0000 --- gcc-3.3/gcc/ada/a-nudira.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nudira.ads gcc-3.3/gcc/ada/a-nudira.ads *** gcc-3.2.3/gcc/ada/a-nudira.ads 2002-05-04 03:27:22.000000000 +0000 --- gcc-3.3/gcc/ada/a-nudira.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nuelfu.ads gcc-3.3/gcc/ada/a-nuelfu.ads *** gcc-3.2.3/gcc/ada/a-nuelfu.ads 2001-10-02 13:51:52.000000000 +0000 --- gcc-3.3/gcc/ada/a-nuelfu.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nuflra.adb gcc-3.3/gcc/ada/a-nuflra.adb *** gcc-3.2.3/gcc/ada/a-nuflra.adb 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nuflra.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-nuflra.ads gcc-3.3/gcc/ada/a-nuflra.ads *** gcc-3.2.3/gcc/ada/a-nuflra.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-nuflra.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-numaux.ads gcc-3.3/gcc/ada/a-numaux.ads *** gcc-3.2.3/gcc/ada/a-numaux.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-numaux.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- (C Library Version, non-x86) -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 7,12 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-numeri.ads gcc-3.3/gcc/ada/a-numeri.ads *** gcc-3.2.3/gcc/ada/a-numeri.ads 2002-05-07 08:22:06.000000000 +0000 --- gcc-3.3/gcc/ada/a-numeri.ads 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-reatim.adb gcc-3.3/gcc/ada/a-reatim.adb *** gcc-3.2.3/gcc/ada/a-reatim.adb 2001-12-18 00:03:37.000000000 +0000 --- gcc-3.3/gcc/ada/a-reatim.adb 2002-03-14 10:58:51.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3 $ -- -- ! -- 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-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- -- *************** *** 29,36 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- 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). -- -- -- ------------------------------------------------------------------------------ *************** package body Ada.Real_Time is *** 46,56 **** --- 44,56 ---- -- Note that Constraint_Error may be propagated function "*" (Left : Time_Span; Right : Integer) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) * Right); end "*"; function "*" (Left : Integer; Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Left * Duration (Right)); end "*"; *************** package body Ada.Real_Time is *** 62,77 **** --- 62,80 ---- -- Note that Constraint_Error may be propagated function "+" (Left : Time; Right : Time_Span) return Time is + pragma Unsuppress (Overflow_Check); begin return Time (Duration (Left) + Duration (Right)); end "+"; function "+" (Left : Time_Span; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); begin return Time (Duration (Left) + Duration (Right)); end "+"; function "+" (Left, Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) + Duration (Right)); end "+"; *************** package body Ada.Real_Time is *** 83,103 **** --- 86,110 ---- -- Note that Constraint_Error may be propagated function "-" (Left : Time; Right : Time_Span) return Time is + pragma Unsuppress (Overflow_Check); begin return Time (Duration (Left) - Duration (Right)); end "-"; function "-" (Left, Right : Time) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) - Duration (Right)); end "-"; function "-" (Left, Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) - Duration (Right)); end "-"; function "-" (Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span_Zero - Right; end "-"; *************** package body Ada.Real_Time is *** 109,119 **** --- 116,128 ---- -- Note that Constraint_Error may be propagated function "/" (Left, Right : Time_Span) return Integer is + pragma Unsuppress (Overflow_Check); begin return Integer (Duration (Left) / Duration (Right)); end "/"; function "/" (Left : Time_Span; Right : Integer) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) / Right); end "/"; *************** package body Ada.Real_Time is *** 190,196 **** SC := SC - 1; end if; ! TS := T - Time (SC); end Split; ------------- --- 199,205 ---- SC := SC - 1; end if; ! TS := Time_Span (Duration (T) - Duration (SC)); end Split; ------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-reatim.ads gcc-3.3/gcc/ada/a-reatim.ads *** gcc-3.2.3/gcc/ada/a-reatim.ads 2002-05-04 03:27:23.000000000 +0000 --- gcc-3.3/gcc/ada/a-reatim.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.3.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-retide.adb gcc-3.3/gcc/ada/a-retide.adb *** gcc-3.2.3/gcc/ada/a-retide.adb 2001-10-02 13:51:52.000000000 +0000 --- gcc-3.3/gcc/ada/a-retide.adb 2002-10-28 16:19:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.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- -- --- 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- -- *************** *** 28,49 **** -- 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). -- -- -- ------------------------------------------------------------------------------ with System.Task_Primitives.Operations; -- Used for Timed_Delay - with System.OS_Primitives; - -- Used for Delay_Modes - package body Ada.Real_Time.Delays is package STPO renames System.Task_Primitives.Operations; ! package OSP renames System.OS_Primitives; ----------------- -- Delay_Until -- --- 27,45 ---- -- 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. -- -- -- ------------------------------------------------------------------------------ with System.Task_Primitives.Operations; -- Used for Timed_Delay package body Ada.Real_Time.Delays is package STPO renames System.Task_Primitives.Operations; ! ! Absolute_RT : constant := 2; ----------------- -- Delay_Until -- *************** package body Ada.Real_Time.Delays is *** 51,57 **** procedure Delay_Until (T : Time) is begin ! STPO.Timed_Delay (STPO.Self, To_Duration (T), OSP.Absolute_RT); end Delay_Until; ----------------- --- 47,53 ---- procedure Delay_Until (T : Time) is begin ! STPO.Timed_Delay (STPO.Self, To_Duration (T), Absolute_RT); end Delay_Until; ----------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-retide.ads gcc-3.3/gcc/ada/a-retide.ads *** gcc-3.2.3/gcc/ada/a-retide.ads 2002-05-04 03:27:23.000000000 +0000 --- gcc-3.3/gcc/ada/a-retide.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/argv.c gcc-3.3/gcc/ada/argv.c *** gcc-3.2.3/gcc/ada/argv.c 2002-05-04 03:27:32.000000000 +0000 --- gcc-3.3/gcc/ada/argv.c 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * C Implementation File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-sequio.adb gcc-3.3/gcc/ada/a-sequio.adb *** gcc-3.2.3/gcc/ada/a-sequio.adb 2002-05-04 03:27:23.000000000 +0000 --- gcc-3.3/gcc/ada/a-sequio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-sequio.ads gcc-3.3/gcc/ada/a-sequio.ads *** gcc-3.2.3/gcc/ada/a-sequio.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-sequio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-sfteio.ads gcc-3.3/gcc/ada/a-sfteio.ads *** gcc-3.2.3/gcc/ada/a-sfteio.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-sfteio.ads 2002-03-14 10:58:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-sfwtio.ads gcc-3.3/gcc/ada/a-sfwtio.ads *** gcc-3.2.3/gcc/ada/a-sfwtio.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-sfwtio.ads 2002-03-14 10:58:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-siocst.adb gcc-3.3/gcc/ada/a-siocst.adb *** gcc-3.2.3/gcc/ada/a-siocst.adb 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-siocst.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-siocst.ads gcc-3.3/gcc/ada/a-siocst.ads *** gcc-3.2.3/gcc/ada/a-siocst.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-siocst.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-siteio.ads gcc-3.3/gcc/ada/a-siteio.ads *** gcc-3.2.3/gcc/ada/a-siteio.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-siteio.ads 2002-03-14 10:58:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-siwtio.ads gcc-3.3/gcc/ada/a-siwtio.ads *** gcc-3.2.3/gcc/ada/a-siwtio.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-siwtio.ads 2002-03-14 10:58:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ssicst.adb gcc-3.3/gcc/ada/a-ssicst.adb *** gcc-3.2.3/gcc/ada/a-ssicst.adb 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-ssicst.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ssicst.ads gcc-3.3/gcc/ada/a-ssicst.ads *** gcc-3.2.3/gcc/ada/a-ssicst.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-ssicst.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ssitio.ads gcc-3.3/gcc/ada/a-ssitio.ads *** gcc-3.2.3/gcc/ada/a-ssitio.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-ssitio.ads 2002-03-14 10:58:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ssiwti.ads gcc-3.3/gcc/ada/a-ssiwti.ads *** gcc-3.2.3/gcc/ada/a-ssiwti.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-ssiwti.ads 2002-03-14 10:58:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stmaco.ads gcc-3.3/gcc/ada/a-stmaco.ads *** gcc-3.2.3/gcc/ada/a-stmaco.ads 2002-05-04 03:27:23.000000000 +0000 --- gcc-3.3/gcc/ada/a-stmaco.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-storio.adb gcc-3.3/gcc/ada/a-storio.adb *** gcc-3.2.3/gcc/ada/a-storio.adb 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-storio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-storio.ads gcc-3.3/gcc/ada/a-storio.ads *** gcc-3.2.3/gcc/ada/a-storio.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-storio.ads 2002-03-14 10:58:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strbou.adb gcc-3.3/gcc/ada/a-strbou.adb *** gcc-3.2.3/gcc/ada/a-strbou.adb 2002-05-04 03:27:23.000000000 +0000 --- gcc-3.3/gcc/ada/a-strbou.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strbou.ads gcc-3.3/gcc/ada/a-strbou.ads *** gcc-3.2.3/gcc/ada/a-strbou.ads 2002-05-04 03:27:23.000000000 +0000 --- gcc-3.3/gcc/ada/a-strbou.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stream.ads gcc-3.3/gcc/ada/a-stream.ads *** gcc-3.2.3/gcc/ada/a-stream.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-stream.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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 -- *************** pragma Pure (Streams); *** 53,59 **** Stream_Element_Offset range 0 .. Stream_Element_Offset'Last; type Stream_Element_Array is ! array (Stream_Element_Offset range <>) of Stream_Element; procedure Read (Stream : in out Root_Stream_Type; --- 52,58 ---- Stream_Element_Offset range 0 .. Stream_Element_Offset'Last; type Stream_Element_Array is ! array (Stream_Element_Offset range <>) of aliased Stream_Element; procedure Read (Stream : in out Root_Stream_Type; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strfix.adb gcc-3.3/gcc/ada/a-strfix.adb *** gcc-3.2.3/gcc/ada/a-strfix.adb 2002-05-04 03:27:23.000000000 +0000 --- gcc-3.3/gcc/ada/a-strfix.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strfix.ads gcc-3.3/gcc/ada/a-strfix.ads *** gcc-3.2.3/gcc/ada/a-strfix.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-strfix.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-string.ads gcc-3.3/gcc/ada/a-string.ads *** gcc-3.2.3/gcc/ada/a-string.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-string.ads 2002-03-14 10:58:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strmap.adb gcc-3.3/gcc/ada/a-strmap.adb *** gcc-3.2.3/gcc/ada/a-strmap.adb 2002-05-04 03:27:24.000000000 +0000 --- gcc-3.3/gcc/ada/a-strmap.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strmap.ads gcc-3.3/gcc/ada/a-strmap.ads *** gcc-3.2.3/gcc/ada/a-strmap.ads 2002-05-04 03:27:24.000000000 +0000 --- gcc-3.3/gcc/ada/a-strmap.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strsea.adb gcc-3.3/gcc/ada/a-strsea.adb *** gcc-3.2.3/gcc/ada/a-strsea.adb 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-strsea.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strsea.ads gcc-3.3/gcc/ada/a-strsea.ads *** gcc-3.2.3/gcc/ada/a-strsea.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-strsea.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strunb.adb gcc-3.3/gcc/ada/a-strunb.adb *** gcc-3.2.3/gcc/ada/a-strunb.adb 2002-05-04 03:27:24.000000000 +0000 --- gcc-3.3/gcc/ada/a-strunb.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-strunb.ads gcc-3.3/gcc/ada/a-strunb.ads *** gcc-3.2.3/gcc/ada/a-strunb.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-strunb.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ststio.adb gcc-3.3/gcc/ada/a-ststio.adb *** gcc-3.2.3/gcc/ada/a-ststio.adb 2002-05-04 03:27:24.000000000 +0000 --- gcc-3.3/gcc/ada/a-ststio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** package body Ada.Streams.Stream_IO is *** 64,69 **** --- 63,70 ---- ------------------- function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin return new Stream_AFCB; end AFCB_Allocate; *************** package body Ada.Streams.Stream_IO is *** 75,80 **** --- 76,83 ---- -- No special processing required for closing Stream_IO file procedure AFCB_Close (File : access Stream_AFCB) is + pragma Warnings (Off, File); + begin null; end AFCB_Close; *************** package body Ada.Streams.Stream_IO is *** 149,155 **** -- Flush -- ----------- ! procedure Flush (File : in out File_Type) is begin FIO.Flush (AP (File)); end Flush; --- 152,158 ---- -- Flush -- ----------- ! procedure Flush (File : File_Type) is begin FIO.Flush (AP (File)); end Flush; *************** package body Ada.Streams.Stream_IO is *** 261,270 **** if File.Last_Op /= Op_Read or else File.Shared_Status = FCB.Yes then - if End_Of_File (File) then - raise End_Error; - end if; - Locked_Processing : begin SSL.Lock_Task.all; Set_Position (File); --- 264,269 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ststio.ads gcc-3.3/gcc/ada/a-ststio.ads *** gcc-3.2.3/gcc/ada/a-ststio.ads 2002-05-07 08:22:07.000000000 +0000 --- gcc-3.3/gcc/ada/a-ststio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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 -- *************** package Ada.Streams.Stream_IO is *** 128,134 **** procedure Set_Mode (File : in out File_Type; Mode : in File_Mode); ! procedure Flush (File : in out File_Type); ---------------- -- Exceptions -- --- 127,136 ---- procedure Set_Mode (File : in out File_Type; Mode : in File_Mode); ! -- Note: The parameter file is IN OUT in the RM, but this is clearly ! -- an oversight, and was intended to be IN, see AI95-00057. ! ! procedure Flush (File : File_Type); ---------------- -- Exceptions -- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stunau.adb gcc-3.3/gcc/ada/a-stunau.adb *** gcc-3.2.3/gcc/ada/a-stunau.adb 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-stunau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stunau.ads gcc-3.3/gcc/ada/a-stunau.ads *** gcc-3.2.3/gcc/ada/a-stunau.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-stunau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwibo.adb gcc-3.3/gcc/ada/a-stwibo.adb *** gcc-3.2.3/gcc/ada/a-stwibo.adb 2002-05-04 03:27:24.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwibo.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwibo.ads gcc-3.3/gcc/ada/a-stwibo.ads *** gcc-3.2.3/gcc/ada/a-stwibo.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwibo.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwifi.adb gcc-3.3/gcc/ada/a-stwifi.adb *** gcc-3.2.3/gcc/ada/a-stwifi.adb 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwifi.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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- -- *************** *** 33,39 **** -- -- ------------------------------------------------------------------------------ - with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; with Ada.Strings.Wide_Search; --- 32,37 ---- *************** package body Ada.Strings.Wide_Fixed is *** 158,166 **** else declare ! Result : constant Wide_String := ! Source (Source'First .. From - 1) & ! Source (Through + 1 .. Source'Last); begin return Result; end; --- 156,166 ---- else declare ! Len : constant Integer := Source'Length - (Through - From + 1); ! Result : constant ! Wide_String (Source'First .. Source'First + Len - 1) := ! Source (Source'First .. From - 1) & ! Source (Through + 1 .. Source'Last); begin return Result; end; *************** package body Ada.Strings.Wide_Fixed is *** 381,393 **** else declare Result_Length : Natural := ! Natural'Max (Source'Length, ! Position - Source'First + New_Item'Length); Result : Wide_String (1 .. Result_Length); begin Result := Source (Source'First .. Position - 1) & New_Item & ! Source (Position + New_Item'Length .. Source'Last); return Result; end; end if; --- 381,395 ---- else declare Result_Length : Natural := ! Natural'Max ! (Source'Length, ! Position - Source'First + New_Item'Length); ! Result : Wide_String (1 .. Result_Length); begin Result := Source (Source'First .. Position - 1) & New_Item & ! Source (Position + New_Item'Length .. Source'Last); return Result; end; end if; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwifi.ads gcc-3.3/gcc/ada/a-stwifi.ads *** gcc-3.2.3/gcc/ada/a-stwifi.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwifi.ads 2002-03-14 10:58:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwima.adb gcc-3.3/gcc/ada/a-stwima.adb *** gcc-3.2.3/gcc/ada/a-stwima.adb 2002-05-04 03:27:24.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwima.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwima.ads gcc-3.3/gcc/ada/a-stwima.ads *** gcc-3.2.3/gcc/ada/a-stwima.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwima.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwise.adb gcc-3.3/gcc/ada/a-stwise.adb *** gcc-3.2.3/gcc/ada/a-stwise.adb 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwise.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwise.ads gcc-3.3/gcc/ada/a-stwise.ads *** gcc-3.2.3/gcc/ada/a-stwise.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwise.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwiun.adb gcc-3.3/gcc/ada/a-stwiun.adb *** gcc-3.2.3/gcc/ada/a-stwiun.adb 2002-05-04 03:27:25.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwiun.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-stwiun.ads gcc-3.3/gcc/ada/a-stwiun.ads *** gcc-3.2.3/gcc/ada/a-stwiun.ads 2002-05-04 03:27:25.000000000 +0000 --- gcc-3.3/gcc/ada/a-stwiun.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-suteio.adb gcc-3.3/gcc/ada/a-suteio.adb *** gcc-3.2.3/gcc/ada/a-suteio.adb 2002-05-04 03:27:25.000000000 +0000 --- gcc-3.3/gcc/ada/a-suteio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-suteio.ads gcc-3.3/gcc/ada/a-suteio.ads *** gcc-3.2.3/gcc/ada/a-suteio.ads 2002-05-04 03:27:25.000000000 +0000 --- gcc-3.3/gcc/ada/a-suteio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-swmwco.ads gcc-3.3/gcc/ada/a-swmwco.ads *** gcc-3.2.3/gcc/ada/a-swmwco.ads 2002-05-04 03:27:25.000000000 +0000 --- gcc-3.3/gcc/ada/a-swmwco.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-swuwti.adb gcc-3.3/gcc/ada/a-swuwti.adb *** gcc-3.2.3/gcc/ada/a-swuwti.adb 2002-05-04 03:27:25.000000000 +0000 --- gcc-3.3/gcc/ada/a-swuwti.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-swuwti.ads gcc-3.3/gcc/ada/a-swuwti.ads *** gcc-3.2.3/gcc/ada/a-swuwti.ads 2002-05-04 03:27:25.000000000 +0000 --- gcc-3.3/gcc/ada/a-swuwti.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-sytaco.adb gcc-3.3/gcc/ada/a-sytaco.adb *** gcc-3.2.3/gcc/ada/a-sytaco.adb 2002-05-04 03:27:25.000000000 +0000 --- gcc-3.3/gcc/ada/a-sytaco.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-sytaco.ads gcc-3.3/gcc/ada/a-sytaco.ads *** gcc-3.2.3/gcc/ada/a-sytaco.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-sytaco.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tags.adb gcc-3.3/gcc/ada/a-tags.adb *** gcc-3.2.3/gcc/ada/a-tags.adb 2002-05-04 03:27:26.000000000 +0000 --- gcc-3.3/gcc/ada/a-tags.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Ada.Tags is *** 63,70 **** -- | tags | -- +-------------------+ - use System; - subtype Cstring is String (Positive); type Cstring_Ptr is access all Cstring; type Tag_Table is array (Natural range <>) of Tag; --- 62,67 ---- *************** package body Ada.Tags is *** 93,113 **** ------------------------------------------- function To_Type_Specific_Data_Ptr is ! new Unchecked_Conversion (Address, Type_Specific_Data_Ptr); - function To_Address is new Unchecked_Conversion (Tag, Address); function To_Address is ! new Unchecked_Conversion (Type_Specific_Data_Ptr, Address); --------------------------------------------- -- Unchecked Conversions for String Fields -- --------------------------------------------- function To_Cstring_Ptr is ! new Unchecked_Conversion (Address, Cstring_Ptr); function To_Address is ! new Unchecked_Conversion (Cstring_Ptr, Address); ----------------------- -- Local Subprograms -- --- 90,109 ---- ------------------------------------------- function To_Type_Specific_Data_Ptr is ! new Unchecked_Conversion (S.Address, Type_Specific_Data_Ptr); function To_Address is ! new Unchecked_Conversion (Type_Specific_Data_Ptr, S.Address); --------------------------------------------- -- Unchecked Conversions for String Fields -- --------------------------------------------- function To_Cstring_Ptr is ! new Unchecked_Conversion (S.Address, Cstring_Ptr); function To_Address is ! new Unchecked_Conversion (Cstring_Ptr, S.Address); ----------------------- -- Local Subprograms -- *************** package body Ada.Tags is *** 130,137 **** package HTable_Subprograms is procedure Set_HT_Link (T : Tag; Next : Tag); function Get_HT_Link (T : Tag) return Tag; ! function Hash (F : Address) return HTable_Headers; ! function Equal (A, B : Address) return Boolean; end HTable_Subprograms; package External_Tag_HTable is new GNAT.HTable.Static_HTable ( --- 126,133 ---- package HTable_Subprograms is procedure Set_HT_Link (T : Tag; Next : Tag); function Get_HT_Link (T : Tag) return Tag; ! function Hash (F : S.Address) return HTable_Headers; ! function Equal (A, B : S.Address) return Boolean; end HTable_Subprograms; package External_Tag_HTable is new GNAT.HTable.Static_HTable ( *************** package body Ada.Tags is *** 141,147 **** Null_Ptr => null, Set_Next => HTable_Subprograms.Set_HT_Link, Next => HTable_Subprograms.Get_HT_Link, ! Key => Address, Get_Key => Get_External_Tag, Hash => HTable_Subprograms.Hash, Equal => HTable_Subprograms.Equal); --- 137,143 ---- Null_Ptr => null, Set_Next => HTable_Subprograms.Set_HT_Link, Next => HTable_Subprograms.Get_HT_Link, ! Key => S.Address, Get_Key => Get_External_Tag, Hash => HTable_Subprograms.Hash, Equal => HTable_Subprograms.Equal); *************** package body Ada.Tags is *** 158,164 **** -- Equal -- ----------- ! function Equal (A, B : Address) return Boolean is Str1 : Cstring_Ptr := To_Cstring_Ptr (A); Str2 : Cstring_Ptr := To_Cstring_Ptr (B); J : Integer := 1; --- 154,160 ---- -- Equal -- ----------- ! 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; *************** package body Ada.Tags is *** 190,196 **** -- Hash -- ---------- ! function Hash (F : 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))); --- 186,192 ---- -- Hash -- ---------- ! 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))); *************** package body Ada.Tags is *** 262,268 **** -- Get_Expanded_Name -- ----------------------- ! function Get_Expanded_Name (T : Tag) return Address is begin return To_Address (T.TSD.Expanded_Name); end Get_Expanded_Name; --- 258,264 ---- -- Get_Expanded_Name -- ----------------------- ! function Get_Expanded_Name (T : Tag) return S.Address is begin return To_Address (T.TSD.Expanded_Name); end Get_Expanded_Name; *************** package body Ada.Tags is *** 271,277 **** -- Get_External_Tag -- ---------------------- ! function Get_External_Tag (T : Tag) return Address is begin return To_Address (T.TSD.External_Tag); end Get_External_Tag; --- 267,273 ---- -- Get_External_Tag -- ---------------------- ! function Get_External_Tag (T : Tag) return S.Address is begin return To_Address (T.TSD.External_Tag); end Get_External_Tag; *************** package body Ada.Tags is *** 292,298 **** function Get_Prim_Op_Address (T : Tag; Position : Positive) ! return Address is begin return T.Prims_Ptr (Position); --- 288,294 ---- function Get_Prim_Op_Address (T : Tag; Position : Positive) ! return S.Address is begin return T.Prims_Ptr (Position); *************** package body Ada.Tags is *** 320,326 **** -- Get_TSD -- ------------- ! function Get_TSD (T : Tag) return Address is begin return To_Address (T.TSD); end Get_TSD; --- 316,322 ---- -- Get_TSD -- ------------- ! function Get_TSD (T : Tag) return S.Address is begin return To_Address (T.TSD); end Get_TSD; *************** package body Ada.Tags is *** 345,351 **** -- Inherit_TSD -- ----------------- ! procedure Inherit_TSD (Old_TSD : Address; New_Tag : Tag) is TSD : constant Type_Specific_Data_Ptr := To_Type_Specific_Data_Ptr (Old_TSD); New_TSD : Type_Specific_Data renames New_Tag.TSD.all; --- 341,347 ---- -- Inherit_TSD -- ----------------- ! procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag) 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 Ada.Tags is *** 422,435 **** type T_Ptr is access all T; ! function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr); -- The profile of the implicitly defined _size primitive ! type Acc_Size is access function (A : Address) return Long_Long_Integer; ! function To_Acc_Size is new Unchecked_Conversion (Address, Acc_Size); ! function Parent_Size (Obj : Address) return SSE.Storage_Count is -- Get the tag of the object --- 418,431 ---- 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 *************** package body Ada.Tags is *** 463,469 **** -- Set_Expanded_Name -- ----------------------- ! procedure Set_Expanded_Name (T : Tag; Value : Address) is begin T.TSD.Expanded_Name := To_Cstring_Ptr (Value); end Set_Expanded_Name; --- 459,465 ---- -- Set_Expanded_Name -- ----------------------- ! procedure Set_Expanded_Name (T : Tag; Value : S.Address) is begin T.TSD.Expanded_Name := To_Cstring_Ptr (Value); end Set_Expanded_Name; *************** package body Ada.Tags is *** 472,478 **** -- Set_External_Tag -- ---------------------- ! procedure Set_External_Tag (T : Tag; Value : Address) is begin T.TSD.External_Tag := To_Cstring_Ptr (Value); end Set_External_Tag; --- 468,474 ---- -- Set_External_Tag -- ---------------------- ! procedure Set_External_Tag (T : Tag; Value : S.Address) is begin T.TSD.External_Tag := To_Cstring_Ptr (Value); end Set_External_Tag; *************** package body Ada.Tags is *** 496,502 **** procedure Set_Prim_Op_Address (T : Tag; Position : Positive; ! Value : Address) is begin T.Prims_Ptr (Position) := Value; --- 492,498 ---- procedure Set_Prim_Op_Address (T : Tag; Position : Positive; ! Value : S.Address) is begin T.Prims_Ptr (Position) := Value; *************** package body Ada.Tags is *** 528,534 **** -- Set_TSD -- ------------- ! procedure Set_TSD (T : Tag; Value : Address) is begin T.TSD := To_Type_Specific_Data_Ptr (Value); end Set_TSD; --- 524,530 ---- -- Set_TSD -- ------------- ! procedure Set_TSD (T : Tag; Value : S.Address) is begin T.TSD := To_Type_Specific_Data_Ptr (Value); end Set_TSD; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tags.ads gcc-3.3/gcc/ada/a-tags.ads *** gcc-3.2.3/gcc/ada/a-tags.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-tags.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.10.2 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tasatt.adb gcc-3.3/gcc/ada/a-tasatt.adb *** gcc-3.2.3/gcc/ada/a-tasatt.adb 2001-12-16 01:13:32.000000000 +0000 --- gcc-3.3/gcc/ada/a-tasatt.adb 2002-03-14 10:58:55.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- ! -- 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-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- -- *************** *** 29,36 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- 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). -- -- -- ------------------------------------------------------------------------------ *************** *** 182,189 **** -- The latter initialization requires a list of all the instantiation -- descriptors. Updates to this list, as well as the bit-vector that -- is used to reserve slots for attributes in the TCB, require mutual ! -- exclusion. That is provided by the lock ! -- System.Tasking.Task_Attributes.All_Attrs_L. -- One special problem that added complexity to the design is that -- the per-task list of indirect attributes contains objects of --- 180,186 ---- -- The latter initialization requires a list of all the instantiation -- descriptors. Updates to this list, as well as the bit-vector that -- is used to reserve slots for attributes in the TCB, require mutual ! -- exclusion. That is provided by the Lock/Unlock_RTS. -- One special problem that added complexity to the design is that -- the per-task list of indirect attributes contains objects of *************** with System.Storage_Elements; *** 243,249 **** with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock ! -- Lock/Unlock_All_Tasks_List with System.Tasking; -- used for Access_Address --- 240,246 ---- with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock ! -- Lock/Unlock_RTS with System.Tasking; -- used for Access_Address *************** package body Ada.Task_Attributes is *** 301,306 **** --- 298,311 ---- type Wrapper; type Access_Wrapper is access all Wrapper; + pragma Warnings (Off); + -- We turn warnings off for the following declarations of the + -- To_Attribute_Handle conversions, since these are used only + -- for small attributes where we know that there are no problems + -- with alignment, but the compiler will generate warnings for + -- the occurrences in the large attribute case, even though + -- 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 *************** package body Ada.Task_Attributes is *** 312,317 **** --- 317,326 ---- (Access_Integer_Address, Attribute_Handle); -- For reference to directly addressed task attributes + pragma Warnings (On); + -- End of warnings off region for directly addressed + -- attribute conversion functions. + function To_Access_Address is new Unchecked_Conversion (Access_Node, Access_Address); -- To store pointer to list of indirect attributes *************** package body Ada.Task_Attributes is *** 320,328 **** (Access_Address, Access_Node); -- To fetch pointer to list of indirect attributes function To_Access_Wrapper is new Unchecked_Conversion (Access_Dummy_Wrapper, Access_Wrapper); ! -- To fetch pointer to actual wrapper of attribute node function To_Access_Dummy_Wrapper is new Unchecked_Conversion (Access_Wrapper, Access_Dummy_Wrapper); --- 329,343 ---- (Access_Address, Access_Node); -- To fetch pointer to list of indirect attributes + pragma Warnings (Off); function To_Access_Wrapper is new Unchecked_Conversion (Access_Dummy_Wrapper, Access_Wrapper); ! pragma Warnings (On); ! -- To fetch pointer to actual wrapper of attribute node. We turn off ! -- warnings since this may generate an alignment warning. The warning ! -- can be ignored since Dummy_Wrapper is only a non-generic standin ! -- for the real wrapper type (we never actually allocate objects of ! -- type Dummy_Wrapper). function To_Access_Dummy_Wrapper is new Unchecked_Conversion (Access_Wrapper, Access_Dummy_Wrapper); *************** package body Ada.Task_Attributes is *** 388,394 **** (T : Task_Identification.Task_Id := Task_Identification.Current_Task) return Attribute_Handle is ! TT : Task_ID := To_Task_ID (T); Error_Message : constant String := "Trying to get the reference of a"; begin --- 403,409 ---- (T : Task_Identification.Task_Id := Task_Identification.Current_Task) return Attribute_Handle is ! TT : Task_ID := To_Task_ID (T); Error_Message : constant String := "Trying to get the reference of a"; begin *************** package body Ada.Task_Attributes is *** 404,416 **** begin Defer_Abortion; ! POP.Write_Lock (All_Attrs_L'Access); if Local.Index /= 0 then ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; return To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access); else declare --- 419,442 ---- 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 *************** package body Ada.Task_Attributes is *** 420,426 **** begin while P /= null loop if P.Instance = Access_Instance'(Local'Unchecked_Access) then ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; return To_Access_Wrapper (P.Wrapper).Value'Access; end if; --- 446,452 ---- 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; *************** package body Ada.Task_Attributes is *** 428,447 **** P := P.Next; end loop; ! -- Unlock All_Attrs_L 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 (All_Attrs_L'Access); W := new Wrapper' ((null, Local'Unchecked_Access, null), Initial_Value); ! POP.Write_Lock (All_Attrs_L'Access); 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 (All_Attrs_L'Access); Undefer_Abortion; return W.Value'Access; end; --- 454,473 ---- 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; *************** package body Ada.Task_Attributes is *** 452,458 **** exception when others => ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; raise; end; --- 478,484 ---- exception when others => ! POP.Unlock_RTS; Undefer_Abortion; raise; end; *************** package body Ada.Task_Attributes is *** 493,501 **** begin Defer_Abortion; ! POP.Write_Lock (All_Attrs_L'Access); ! Q := To_Access_Node (TT.Indirect_Attributes); while Q /= null loop if Q.Instance = Access_Instance'(Local'Unchecked_Access) then if P = null then --- 519,527 ---- begin Defer_Abortion; ! POP.Lock_RTS; Q := To_Access_Node (TT.Indirect_Attributes); + while Q /= null loop if Q.Instance = Access_Instance'(Local'Unchecked_Access) then if P = null then *************** package body Ada.Task_Attributes is *** 506,512 **** W := To_Access_Wrapper (Q.Wrapper); Free (W); ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; return; end if; --- 532,538 ---- W := To_Access_Wrapper (Q.Wrapper); Free (W); ! POP.Unlock_RTS; Undefer_Abortion; return; end if; *************** package body Ada.Task_Attributes is *** 515,526 **** Q := Q.Next; end loop; ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; exception when others => ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; end; --- 541,552 ---- Q := Q.Next; end loop; ! POP.Unlock_RTS; Undefer_Abortion; exception when others => ! POP.Unlock_RTS; Undefer_Abortion; end; *************** package body Ada.Task_Attributes is *** 560,574 **** begin Defer_Abortion; ! POP.Write_Lock (All_Attrs_L'Access); if Local.Index /= 0 then To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access).all := Val; ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; return; else declare P : Access_Node := To_Access_Node (TT.Indirect_Attributes); --- 586,612 ---- 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); *************** package body Ada.Task_Attributes is *** 579,585 **** if P.Instance = Access_Instance'(Local'Unchecked_Access) then To_Access_Wrapper (P.Wrapper).Value := Val; ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; return; end if; --- 617,623 ---- if P.Instance = Access_Instance'(Local'Unchecked_Access) then To_Access_Wrapper (P.Wrapper).Value := Val; ! POP.Unlock_RTS; Undefer_Abortion; return; end if; *************** package body Ada.Task_Attributes is *** 587,601 **** P := P.Next; end loop; ! -- Unlock TT 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 (All_Attrs_L'Access); W := new Wrapper' ((null, Local'Unchecked_Access, null), Val); ! POP.Write_Lock (All_Attrs_L'Access); ! P := W.Noed'Unchecked_Access; P.Wrapper := To_Access_Dummy_Wrapper (W); P.Next := To_Access_Node (TT.Indirect_Attributes); --- 625,638 ---- 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); *************** package body Ada.Task_Attributes is *** 603,614 **** end; end if; ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; exception when others => ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; raise; end; --- 640,651 ---- end; end if; ! POP.Unlock_RTS; Undefer_Abortion; exception when others => ! POP.Unlock_RTS; Undefer_Abortion; raise; end; *************** package body Ada.Task_Attributes is *** 648,657 **** --- 685,706 ---- 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 *************** package body Ada.Task_Attributes is *** 659,670 **** begin Defer_Abortion; ! POP.Write_Lock (All_Attrs_L'Access); ! P := To_Access_Node (TT.Indirect_Attributes); while P /= null loop if P.Instance = Access_Instance'(Local'Unchecked_Access) then ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; return To_Access_Wrapper (P.Wrapper).Value; end if; --- 708,719 ---- 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; *************** package body Ada.Task_Attributes is *** 673,684 **** end loop; Result := Initial_Value; ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; exception when others => ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; raise; end; --- 722,733 ---- end loop; Result := Initial_Value; ! POP.Unlock_RTS; Undefer_Abortion; exception when others => ! POP.Unlock_RTS; Undefer_Abortion; raise; end; *************** begin *** 707,717 **** pragma Warnings (On); declare ! Two_To_J : Direct_Index_Vector; ! begin Defer_Abortion; ! POP.Write_Lock (All_Attrs_L'Access); -- Add this instantiation to the list of all instantiations. --- 756,770 ---- pragma Warnings (On); declare ! Two_To_J : Direct_Index_Vector; begin Defer_Abortion; ! ! -- Need protection for updating links to per-task initialization and ! -- finalization routines, in case some task is being created or ! -- terminated concurrently. ! ! POP.Lock_RTS; -- Add this instantiation to the list of all instantiations. *************** begin *** 749,760 **** end loop; end if; - -- Need protection of All_Tasks_L for updating links to - -- per-task initialization and finalization routines, - -- in case some task is being created or terminated concurrently. - - POP.Lock_All_Tasks_List; - -- Attribute goes directly in the TCB if Local.Index /= 0 then --- 802,807 ---- *************** begin *** 791,798 **** end if; ! POP.Unlock_All_Tasks_List; ! POP.Unlock (All_Attrs_L'Access); Undefer_Abortion; exception --- 838,844 ---- end if; ! POP.Unlock_RTS; Undefer_Abortion; exception *************** begin *** 804,808 **** -- any initializations that succeeded up to this point, or we will -- risk a dangling reference when the task terminates. end; - end Ada.Task_Attributes; --- 850,853 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tasatt.ads gcc-3.3/gcc/ada/a-tasatt.ads *** gcc-3.2.3/gcc/ada/a-tasatt.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-tasatt.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-taside.adb gcc-3.3/gcc/ada/a-taside.adb *** gcc-3.2.3/gcc/ada/a-taside.adb 2002-05-04 03:27:26.000000000 +0000 --- gcc-3.3/gcc/ada/a-taside.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-taside.ads gcc-3.3/gcc/ada/a-taside.ads *** gcc-3.2.3/gcc/ada/a-taside.ads 2002-05-04 03:27:26.000000000 +0000 --- gcc-3.3/gcc/ada/a-taside.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-teioed.adb gcc-3.3/gcc/ada/a-teioed.adb *** gcc-3.2.3/gcc/ada/a-teioed.adb 2002-05-04 03:27:26.000000000 +0000 --- gcc-3.3/gcc/ada/a-teioed.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-teioed.ads gcc-3.3/gcc/ada/a-teioed.ads *** gcc-3.2.3/gcc/ada/a-teioed.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-teioed.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-textio.adb gcc-3.3/gcc/ada/a-textio.adb *** gcc-3.2.3/gcc/ada/a-textio.adb 2002-05-04 03:27:26.000000000 +0000 --- gcc-3.3/gcc/ada/a-textio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Ada.Text_IO is *** 58,63 **** --- 57,64 ---- ------------------- function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin return new Text_AFCB; end AFCB_Allocate; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-textio.ads gcc-3.3/gcc/ada/a-textio.ads *** gcc-3.2.3/gcc/ada/a-textio.ads 2002-05-04 03:27:27.000000000 +0000 --- gcc-3.3/gcc/ada/a-textio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ticoau.adb gcc-3.3/gcc/ada/a-ticoau.adb *** gcc-3.2.3/gcc/ada/a-ticoau.adb 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-ticoau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ticoau.ads gcc-3.3/gcc/ada/a-ticoau.ads *** gcc-3.2.3/gcc/ada/a-ticoau.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-ticoau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ticoio.adb gcc-3.3/gcc/ada/a-ticoio.adb *** gcc-3.2.3/gcc/ada/a-ticoio.adb 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-ticoio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-ticoio.ads gcc-3.3/gcc/ada/a-ticoio.ads *** gcc-3.2.3/gcc/ada/a-ticoio.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-ticoio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tideau.adb gcc-3.3/gcc/ada/a-tideau.adb *** gcc-3.2.3/gcc/ada/a-tideau.adb 2002-05-04 03:27:28.000000000 +0000 --- gcc-3.3/gcc/ada/a-tideau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Ada.Text_IO.Decimal_Aux is *** 68,74 **** end if; Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); return Item; end Get_Dec; --- 67,73 ---- end if; Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; end Get_Dec; *************** package body Ada.Text_IO.Decimal_Aux is *** 97,103 **** end if; Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); return Item; end Get_LLD; --- 96,102 ---- end if; Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; end Get_LLD; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tideau.ads gcc-3.3/gcc/ada/a-tideau.ads *** gcc-3.2.3/gcc/ada/a-tideau.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-tideau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tideio.adb gcc-3.3/gcc/ada/a-tideio.adb *** gcc-3.2.3/gcc/ada/a-tideio.adb 2002-05-04 03:27:28.000000000 +0000 --- gcc-3.3/gcc/ada/a-tideio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tideio.ads gcc-3.3/gcc/ada/a-tideio.ads *** gcc-3.2.3/gcc/ada/a-tideio.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-tideio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tienau.adb gcc-3.3/gcc/ada/a-tienau.adb *** gcc-3.2.3/gcc/ada/a-tienau.adb 2002-05-04 03:27:28.000000000 +0000 --- gcc-3.3/gcc/ada/a-tienau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tienau.ads gcc-3.3/gcc/ada/a-tienau.ads *** gcc-3.2.3/gcc/ada/a-tienau.ads 2002-05-07 08:22:08.000000000 +0000 --- gcc-3.3/gcc/ada/a-tienau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tienio.adb gcc-3.3/gcc/ada/a-tienio.adb *** gcc-3.2.3/gcc/ada/a-tienio.adb 2002-05-04 03:27:28.000000000 +0000 --- gcc-3.3/gcc/ada/a-tienio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tienio.ads gcc-3.3/gcc/ada/a-tienio.ads *** gcc-3.2.3/gcc/ada/a-tienio.ads 2002-05-04 03:27:28.000000000 +0000 --- gcc-3.3/gcc/ada/a-tienio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tifiio.adb gcc-3.3/gcc/ada/a-tifiio.adb *** gcc-3.2.3/gcc/ada/a-tifiio.adb 2002-05-04 03:27:28.000000000 +0000 --- gcc-3.3/gcc/ada/a-tifiio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tifiio.ads gcc-3.3/gcc/ada/a-tifiio.ads *** gcc-3.2.3/gcc/ada/a-tifiio.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-tifiio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiflau.adb gcc-3.3/gcc/ada/a-tiflau.adb *** gcc-3.2.3/gcc/ada/a-tiflau.adb 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiflau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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- -- *************** package body Ada.Text_IO.Float_Aux is *** 63,69 **** Item := Scan_Real (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get; ---------- --- 62,68 ---- Item := Scan_Real (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get; ---------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiflau.ads gcc-3.3/gcc/ada/a-tiflau.ads *** gcc-3.2.3/gcc/ada/a-tiflau.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiflau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiflio.adb gcc-3.3/gcc/ada/a-tiflio.adb *** gcc-3.2.3/gcc/ada/a-tiflio.adb 2002-05-04 03:27:28.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiflio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiflio.ads gcc-3.3/gcc/ada/a-tiflio.ads *** gcc-3.2.3/gcc/ada/a-tiflio.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiflio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tigeau.adb gcc-3.3/gcc/ada/a-tigeau.adb *** gcc-3.2.3/gcc/ada/a-tigeau.adb 2002-05-04 03:27:28.000000000 +0000 --- gcc-3.3/gcc/ada/a-tigeau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** package body Ada.Text_IO.Generic_Aux is *** 48,55 **** ------------------------ procedure Check_End_Of_Field ! (File : File_Type; ! Buf : String; Stop : Integer; Ptr : Integer; Width : Field) --- 47,53 ---- ------------------------ procedure Check_End_Of_Field ! (Buf : String; Stop : Integer; Ptr : Integer; Width : Field) diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tigeau.ads gcc-3.3/gcc/ada/a-tigeau.ads *** gcc-3.2.3/gcc/ada/a-tigeau.ads 2002-05-04 03:27:29.000000000 +0000 --- gcc-3.3/gcc/ada/a-tigeau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.3.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** private package Ada.Text_IO.Generic_Aux *** 46,53 **** -- so one of these two routines must be called first. procedure Check_End_Of_Field ! (File : File_Type; ! Buf : String; Stop : Integer; Ptr : Integer; Width : Field); --- 45,51 ---- -- so one of these two routines must be called first. procedure Check_End_Of_Field ! (Buf : String; Stop : Integer; Ptr : Integer; Width : Field); diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiinau.adb gcc-3.3/gcc/ada/a-tiinau.adb *** gcc-3.2.3/gcc/ada/a-tiinau.adb 2002-05-04 03:27:29.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiinau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** package body Ada.Text_IO.Integer_Aux is *** 80,86 **** end if; Item := Scan_Integer (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get_Int; ------------- --- 79,85 ---- end if; Item := Scan_Integer (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_Int; ------------- *************** package body Ada.Text_IO.Integer_Aux is *** 105,111 **** end if; Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get_LLI; -------------- --- 104,110 ---- end if; Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_LLI; -------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiinau.ads gcc-3.3/gcc/ada/a-tiinau.ads *** gcc-3.2.3/gcc/ada/a-tiinau.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiinau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiinio.adb gcc-3.3/gcc/ada/a-tiinio.adb *** gcc-3.2.3/gcc/ada/a-tiinio.adb 2002-05-04 03:27:29.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiinio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiinio.ads gcc-3.3/gcc/ada/a-tiinio.ads *** gcc-3.2.3/gcc/ada/a-tiinio.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiinio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-timoau.adb gcc-3.3/gcc/ada/a-timoau.adb *** gcc-3.2.3/gcc/ada/a-timoau.adb 2002-05-04 03:27:29.000000000 +0000 --- gcc-3.3/gcc/ada/a-timoau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Ada.Text_IO.Modular_Aux is *** 82,88 **** end if; Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get_LLU; ------------- --- 81,87 ---- end if; Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_LLU; ------------- *************** package body Ada.Text_IO.Modular_Aux is *** 107,113 **** end if; Item := Scan_Unsigned (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get_Uns; -------------- --- 106,112 ---- end if; Item := Scan_Unsigned (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_Uns; -------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-timoau.ads gcc-3.3/gcc/ada/a-timoau.ads *** gcc-3.2.3/gcc/ada/a-timoau.ads 2002-05-04 03:27:29.000000000 +0000 --- gcc-3.3/gcc/ada/a-timoau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-timoio.adb gcc-3.3/gcc/ada/a-timoio.adb *** gcc-3.2.3/gcc/ada/a-timoio.adb 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-timoio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-timoio.ads gcc-3.3/gcc/ada/a-timoio.ads *** gcc-3.2.3/gcc/ada/a-timoio.ads 2002-05-04 03:27:29.000000000 +0000 --- gcc-3.3/gcc/ada/a-timoio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1993-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiocst.adb gcc-3.3/gcc/ada/a-tiocst.adb *** gcc-3.2.3/gcc/ada/a-tiocst.adb 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiocst.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-tiocst.ads gcc-3.3/gcc/ada/a-tiocst.ads *** gcc-3.2.3/gcc/ada/a-tiocst.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-tiocst.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-titest.adb gcc-3.3/gcc/ada/a-titest.adb *** gcc-3.2.3/gcc/ada/a-titest.adb 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-titest.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-titest.ads gcc-3.3/gcc/ada/a-titest.ads *** gcc-3.2.3/gcc/ada/a-titest.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-titest.ads 2002-03-14 10:58:59.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/atree.adb gcc-3.3/gcc/ada/atree.adb *** gcc-3.2.3/gcc/ada/atree.adb 2002-05-04 03:27:32.000000000 +0000 --- gcc-3.3/gcc/ada/atree.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Atree is *** 2354,2359 **** --- 2353,2379 ---- return OK; end if; + when OK_Orig => + declare + Onode : constant Node_Id := Original_Node (Node); + + begin + if Traverse_Field (Union_Id (Field1 (Onode))) = Abandon + or else + Traverse_Field (Union_Id (Field2 (Onode))) = Abandon + or else + Traverse_Field (Union_Id (Field3 (Onode))) = Abandon + or else + Traverse_Field (Union_Id (Field4 (Onode))) = Abandon + or else + Traverse_Field (Union_Id (Field5 (Onode))) = Abandon + then + return Abandon; + + else + return OK_Orig; + end if; + end; end case; end Traverse_Func; diff -Nrc3pad gcc-3.2.3/gcc/ada/atree.ads gcc-3.3/gcc/ada/atree.ads *** gcc-3.2.3/gcc/ada/atree.ads 2002-05-04 03:27:32.000000000 +0000 --- gcc-3.3/gcc/ada/atree.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package Atree is *** 495,501 **** -- function is used only by Sinfo.CN to change nodes into their -- corresponding entities. ! type Traverse_Result is (OK, Skip, Abandon); -- This is the type of the result returned by the Process function passed -- to Traverse_Func and Traverse_Proc and also the type of the result of -- Traverse_Func itself. See descriptions below for details. --- 494,500 ---- -- function is used only by Sinfo.CN to change nodes into their -- corresponding entities. ! type Traverse_Result is (OK, OK_Orig, Skip, Abandon); -- This is the type of the result returned by the Process function passed -- to Traverse_Func and Traverse_Proc and also the type of the result of -- Traverse_Func itself. See descriptions below for details. *************** package Atree is *** 508,515 **** -- Process on each one. The traversal is controlled as follows by the -- result returned by Process: ! -- OK The traversal continues normally with the children of ! -- the node just processed. -- Skip The children of the node just processed are skipped and -- excluded from the traversal, but otherwise processing --- 507,517 ---- -- Process on each one. The traversal is controlled as follows by the -- result returned by Process: ! -- OK The traversal continues normally with the syntactic ! -- children of the node just processed. ! ! -- OK_Orig The traversal continues normally with the syntactic ! -- children of the original node of the node just processed. -- Skip The children of the node just processed are skipped and -- excluded from the traversal, but otherwise processing diff -Nrc3pad gcc-3.2.3/gcc/ada/atree.h gcc-3.3/gcc/ada/atree.h *** gcc-3.2.3/gcc/ada/atree.h 2002-05-04 03:27:32.000000000 +0000 --- gcc-3.3/gcc/ada/atree.h 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * C Header File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001, Free Software Foundation, Inc. * * * --- 6,11 ---- *************** struct NFK *** 46,52 **** Boolean rewrite_sub : 1; Boolean rewrite_ins : 1; Boolean analyzed : 1; ! Boolean comes_from_source : 1; Boolean error_posted : 1; Boolean flag4 : 1; --- 45,51 ---- Boolean rewrite_sub : 1; Boolean rewrite_ins : 1; Boolean analyzed : 1; ! Boolean c_f_s : 1; Boolean error_posted : 1; Boolean flag4 : 1; *************** struct NFNK *** 81,87 **** Boolean rewrite_sub : 1; Boolean rewrite_ins : 1; Boolean analyzed : 1; ! Boolean comes_from_source : 1; Boolean error_posted : 1; Boolean flag4 : 1; --- 80,86 ---- Boolean rewrite_sub : 1; Boolean rewrite_ins : 1; Boolean analyzed : 1; ! Boolean c_f_s : 1; Boolean error_posted : 1; Boolean flag4 : 1; *************** struct NFNK *** 101,114 **** Boolean flag17 : 1; Boolean flag18 : 1; ! Boolean flag65 : 1; ! Boolean flag66 : 1; ! Boolean flag67 : 1; ! Boolean flag68 : 1; ! Boolean flag69 : 1; ! Boolean flag70 : 1; ! Boolean flag71 : 1; ! Boolean flag72 : 1; }; /* Structure used for extra flags in third component overlaying Field12 */ --- 100,113 ---- Boolean flag17 : 1; Boolean flag18 : 1; ! Boolean flag65 : 1; ! Boolean flag66 : 1; ! Boolean flag67 : 1; ! Boolean flag68 : 1; ! Boolean flag69 : 1; ! Boolean flag70 : 1; ! Boolean flag71 : 1; ! Boolean flag72 : 1; }; /* Structure used for extra flags in third component overlaying Field12 */ *************** extern Node_Id Current_Error_Node; *** 313,347 **** /* Node Access Functions: */ ! #define Nkind(N) ((Node_Kind)(Nodes_Ptr [N].U.K.kind)) ! #define Ekind(N) ((Entity_Kind)(Nodes_Ptr [N + 1].U.K.kind)) ! #define Sloc(N) (Nodes_Ptr [N].V.NX.sloc) ! #define Paren_Count(N) (Nodes_Ptr [N].U.K.pflag1 \ ! + 2 * Nodes_Ptr [N].U.K.pflag2) ! #define Field1(N) (Nodes_Ptr [N].V.NX.field1) ! #define Field2(N) (Nodes_Ptr [N].V.NX.field2) ! #define Field3(N) (Nodes_Ptr [N].V.NX.field3) ! #define Field4(N) (Nodes_Ptr [N].V.NX.field4) ! #define Field5(N) (Nodes_Ptr [N].V.NX.field5) ! #define Field6(N) (Nodes_Ptr [(N)+1].V.EX.field6) ! #define Field7(N) (Nodes_Ptr [(N)+1].V.EX.field7) ! #define Field8(N) (Nodes_Ptr [(N)+1].V.EX.field8) ! #define Field9(N) (Nodes_Ptr [(N)+1].V.EX.field9) ! #define Field10(N) (Nodes_Ptr [(N)+1].V.EX.field10) ! #define Field11(N) (Nodes_Ptr [(N)+1].V.EX.X.field11) ! #define Field12(N) (Nodes_Ptr [(N)+1].V.EX.U.field12) ! #define Field13(N) (Nodes_Ptr [(N)+2].V.EX.field6) ! #define Field14(N) (Nodes_Ptr [(N)+2].V.EX.field7) ! #define Field15(N) (Nodes_Ptr [(N)+2].V.EX.field8) ! #define Field16(N) (Nodes_Ptr [(N)+2].V.EX.field9) ! #define Field17(N) (Nodes_Ptr [(N)+2].V.EX.field10) ! #define Field18(N) (Nodes_Ptr [(N)+2].V.EX.X.field11) ! #define Field19(N) (Nodes_Ptr [(N)+3].V.EX.field6) ! #define Field20(N) (Nodes_Ptr [(N)+3].V.EX.field7) ! #define Field21(N) (Nodes_Ptr [(N)+3].V.EX.field8) ! #define Field22(N) (Nodes_Ptr [(N)+3].V.EX.field9) ! #define Field23(N) (Nodes_Ptr [(N)+3].V.EX.field10) #define Node1(N) Field1 (N) #define Node2(N) Field2 (N) --- 312,346 ---- /* Node Access Functions: */ ! #define Nkind(N) ((Node_Kind) (Nodes_Ptr[(N) - First_Node_Id].U.K.kind)) ! #define Ekind(N) ((Entity_Kind) (Nodes_Ptr[N + 1].U.K.kind)) ! #define Sloc(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.sloc) ! #define Paren_Count(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.pflag1 \ ! + 2 * Nodes_Ptr[(N) - First_Node_Id].U.K.pflag2) ! #define Field1(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field1) ! #define Field2(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field2) ! #define Field3(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field3) ! #define Field4(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field4) ! #define Field5(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field5) ! #define Field6(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field6) ! #define Field7(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field7) ! #define Field8(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field8) ! #define Field9(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field9) ! #define Field10(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field10) ! #define Field11(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.X.field11) ! #define Field12(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.U.field12) ! #define Field13(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field6) ! #define Field14(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field7) ! #define Field15(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field8) ! #define Field16(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field9) ! #define Field17(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field10) ! #define Field18(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.X.field11) ! #define Field19(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field6) ! #define Field20(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field7) ! #define Field21(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field8) ! #define Field22(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field9) ! #define Field23(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field10) #define Node1(N) Field1 (N) #define Node2(N) Field2 (N) *************** extern Node_Id Current_Error_Node; *** 392,606 **** #define Str3(N) Field3 (N) ! #define Uint3(N) ((Field3 (N)==0) ? Uint_0 : Field3 (N)) ! #define Uint4(N) ((Field4 (N)==0) ? Uint_0 : Field4 (N)) ! #define Uint5(N) ((Field5 (N)==0) ? Uint_0 : Field5 (N)) ! #define Uint8(N) ((Field8 (N)==0) ? Uint_0 : Field8 (N)) ! #define Uint9(N) ((Field9 (N)==0) ? Uint_0 : Field9 (N)) ! #define Uint10(N) ((Field10 (N)==0) ? Uint_0 : Field10 (N)) ! #define Uint11(N) ((Field11 (N)==0) ? Uint_0 : Field11 (N)) ! #define Uint12(N) ((Field12 (N)==0) ? Uint_0 : Field12 (N)) ! #define Uint13(N) ((Field13 (N)==0) ? Uint_0 : Field13 (N)) ! #define Uint14(N) ((Field14 (N)==0) ? Uint_0 : Field14 (N)) ! #define Uint15(N) ((Field15 (N)==0) ? Uint_0 : Field15 (N)) ! #define Uint16(N) ((Field16 (N)==0) ? Uint_0 : Field16 (N)) ! #define Uint17(N) ((Field17 (N)==0) ? Uint_0 : Field17 (N)) ! #define Uint22(N) ((Field22 (N)==0) ? Uint_0 : Field22 (N)) #define Ureal3(N) Field3 (N) #define Ureal18(N) Field18 (N) #define Ureal21(N) Field21 (N) ! #define Analyzed(N) (Nodes_Ptr [N].U.K.analyzed) ! #define Comes_From_Source(N) (Nodes_Ptr [N].U.K.comes_from_source) ! #define Error_Posted(N) (Nodes_Ptr [N].U.K.error_posted) ! ! #define Flag4(N) (Nodes_Ptr [N].U.K.flag4) ! #define Flag5(N) (Nodes_Ptr [N].U.K.flag5) ! #define Flag6(N) (Nodes_Ptr [N].U.K.flag6) ! #define Flag7(N) (Nodes_Ptr [N].U.K.flag7) ! #define Flag8(N) (Nodes_Ptr [N].U.K.flag8) ! #define Flag9(N) (Nodes_Ptr [N].U.K.flag9) ! #define Flag10(N) (Nodes_Ptr [N].U.K.flag10) ! #define Flag11(N) (Nodes_Ptr [N].U.K.flag11) ! #define Flag12(N) (Nodes_Ptr [N].U.K.flag12) ! #define Flag13(N) (Nodes_Ptr [N].U.K.flag13) ! #define Flag14(N) (Nodes_Ptr [N].U.K.flag14) ! #define Flag15(N) (Nodes_Ptr [N].U.K.flag15) ! #define Flag16(N) (Nodes_Ptr [N].U.K.flag16) ! #define Flag17(N) (Nodes_Ptr [N].U.K.flag17) ! #define Flag18(N) (Nodes_Ptr [N].U.K.flag18) ! ! #define Flag19(N) (Nodes_Ptr [(N)+1].U.K.in_list) ! #define Flag20(N) (Nodes_Ptr [(N)+1].U.K.rewrite_sub) ! #define Flag21(N) (Nodes_Ptr [(N)+1].U.K.rewrite_ins) ! #define Flag22(N) (Nodes_Ptr [(N)+1].U.K.analyzed) ! #define Flag23(N) (Nodes_Ptr [(N)+1].U.K.comes_from_source) ! #define Flag24(N) (Nodes_Ptr [(N)+1].U.K.error_posted) ! #define Flag25(N) (Nodes_Ptr [(N)+1].U.K.flag4) ! #define Flag26(N) (Nodes_Ptr [(N)+1].U.K.flag5) ! #define Flag27(N) (Nodes_Ptr [(N)+1].U.K.flag6) ! #define Flag28(N) (Nodes_Ptr [(N)+1].U.K.flag7) ! #define Flag29(N) (Nodes_Ptr [(N)+1].U.K.flag8) ! #define Flag30(N) (Nodes_Ptr [(N)+1].U.K.flag9) ! #define Flag31(N) (Nodes_Ptr [(N)+1].U.K.flag10) ! #define Flag32(N) (Nodes_Ptr [(N)+1].U.K.flag11) ! #define Flag33(N) (Nodes_Ptr [(N)+1].U.K.flag12) ! #define Flag34(N) (Nodes_Ptr [(N)+1].U.K.flag13) ! #define Flag35(N) (Nodes_Ptr [(N)+1].U.K.flag14) ! #define Flag36(N) (Nodes_Ptr [(N)+1].U.K.flag15) ! #define Flag37(N) (Nodes_Ptr [(N)+1].U.K.flag16) ! #define Flag38(N) (Nodes_Ptr [(N)+1].U.K.flag17) ! #define Flag39(N) (Nodes_Ptr [(N)+1].U.K.flag18) ! #define Flag40(N) (Nodes_Ptr [(N)+2].U.K.in_list) ! #define Flag41(N) (Nodes_Ptr [(N)+2].U.K.rewrite_sub) ! #define Flag42(N) (Nodes_Ptr [(N)+2].U.K.rewrite_ins) ! #define Flag43(N) (Nodes_Ptr [(N)+2].U.K.analyzed) ! #define Flag44(N) (Nodes_Ptr [(N)+2].U.K.comes_from_source) ! #define Flag45(N) (Nodes_Ptr [(N)+2].U.K.error_posted) ! #define Flag46(N) (Nodes_Ptr [(N)+2].U.K.flag4) ! #define Flag47(N) (Nodes_Ptr [(N)+2].U.K.flag5) ! #define Flag48(N) (Nodes_Ptr [(N)+2].U.K.flag6) ! #define Flag49(N) (Nodes_Ptr [(N)+2].U.K.flag7) ! #define Flag50(N) (Nodes_Ptr [(N)+2].U.K.flag8) ! #define Flag51(N) (Nodes_Ptr [(N)+2].U.K.flag9) ! #define Flag52(N) (Nodes_Ptr [(N)+2].U.K.flag10) ! #define Flag53(N) (Nodes_Ptr [(N)+2].U.K.flag11) ! #define Flag54(N) (Nodes_Ptr [(N)+2].U.K.flag12) ! #define Flag55(N) (Nodes_Ptr [(N)+2].U.K.flag13) ! #define Flag56(N) (Nodes_Ptr [(N)+2].U.K.flag14) ! #define Flag57(N) (Nodes_Ptr [(N)+2].U.K.flag15) ! #define Flag58(N) (Nodes_Ptr [(N)+2].U.K.flag16) ! #define Flag59(N) (Nodes_Ptr [(N)+2].U.K.flag17) ! #define Flag60(N) (Nodes_Ptr [(N)+2].U.K.flag18) ! #define Flag61(N) (Nodes_Ptr [(N)+1].U.K.pflag1) ! #define Flag62(N) (Nodes_Ptr [(N)+1].U.K.pflag2) ! #define Flag63(N) (Nodes_Ptr [(N)+2].U.K.pflag1) ! #define Flag64(N) (Nodes_Ptr [(N)+2].U.K.pflag2) ! #define Flag65(N) (Nodes_Ptr [(N)+2].U.NK.flag65) ! #define Flag66(N) (Nodes_Ptr [(N)+2].U.NK.flag66) ! #define Flag67(N) (Nodes_Ptr [(N)+2].U.NK.flag67) ! #define Flag68(N) (Nodes_Ptr [(N)+2].U.NK.flag68) ! #define Flag69(N) (Nodes_Ptr [(N)+2].U.NK.flag69) ! #define Flag70(N) (Nodes_Ptr [(N)+2].U.NK.flag70) ! #define Flag71(N) (Nodes_Ptr [(N)+2].U.NK.flag71) ! #define Flag72(N) (Nodes_Ptr [(N)+2].U.NK.flag72) ! #define Flag73(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag73) ! #define Flag74(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag74) ! #define Flag75(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag75) ! #define Flag76(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag76) ! #define Flag77(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag77) ! #define Flag78(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag78) ! #define Flag79(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag79) ! #define Flag80(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag80) ! #define Flag81(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag81) ! #define Flag82(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag82) ! #define Flag83(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag83) ! #define Flag84(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag84) ! #define Flag85(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag85) ! #define Flag86(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag86) ! #define Flag87(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag87) ! #define Flag88(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag88) ! #define Flag89(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag89) ! #define Flag90(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag90) ! #define Flag91(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag91) ! #define Flag92(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag92) ! #define Flag93(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag93) ! #define Flag94(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag94) ! #define Flag95(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag95) ! #define Flag96(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag96) ! #define Convention(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.convention) ! #define Flag97(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag97) ! #define Flag98(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag98) ! #define Flag99(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag99) ! #define Flag100(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag100) ! #define Flag101(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag101) ! #define Flag102(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag102) ! #define Flag103(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag103) ! #define Flag104(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag104) ! #define Flag105(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag105) ! #define Flag106(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag106) ! #define Flag107(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag107) ! #define Flag108(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag108) ! #define Flag109(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag109) ! #define Flag110(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag110) ! #define Flag111(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag111) ! #define Flag112(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag112) ! #define Flag113(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag113) ! #define Flag114(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag114) ! #define Flag115(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag115) ! #define Flag116(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag116) ! #define Flag117(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag117) ! #define Flag118(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag118) ! #define Flag119(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag119) ! #define Flag120(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag120) ! #define Flag121(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag121) ! #define Flag122(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag122) ! #define Flag123(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag123) ! #define Flag124(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag124) ! #define Flag125(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag125) ! #define Flag126(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag126) ! #define Flag127(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag127) ! #define Flag128(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag128) ! #define Flag129(N) (Nodes_Ptr [(N)+3].U.K.in_list) ! #define Flag130(N) (Nodes_Ptr [(N)+3].U.K.rewrite_sub) ! #define Flag131(N) (Nodes_Ptr [(N)+3].U.K.rewrite_ins) ! #define Flag132(N) (Nodes_Ptr [(N)+3].U.K.analyzed) ! #define Flag133(N) (Nodes_Ptr [(N)+3].U.K.comes_from_source) ! #define Flag134(N) (Nodes_Ptr [(N)+3].U.K.error_posted) ! #define Flag135(N) (Nodes_Ptr [(N)+3].U.K.flag4) ! #define Flag136(N) (Nodes_Ptr [(N)+3].U.K.flag5) ! #define Flag137(N) (Nodes_Ptr [(N)+3].U.K.flag6) ! #define Flag138(N) (Nodes_Ptr [(N)+3].U.K.flag7) ! #define Flag139(N) (Nodes_Ptr [(N)+3].U.K.flag8) ! #define Flag140(N) (Nodes_Ptr [(N)+3].U.K.flag9) ! #define Flag141(N) (Nodes_Ptr [(N)+3].U.K.flag10) ! #define Flag142(N) (Nodes_Ptr [(N)+3].U.K.flag11) ! #define Flag143(N) (Nodes_Ptr [(N)+3].U.K.flag12) ! #define Flag144(N) (Nodes_Ptr [(N)+3].U.K.flag13) ! #define Flag145(N) (Nodes_Ptr [(N)+3].U.K.flag14) ! #define Flag146(N) (Nodes_Ptr [(N)+3].U.K.flag15) ! #define Flag147(N) (Nodes_Ptr [(N)+3].U.K.flag16) ! #define Flag148(N) (Nodes_Ptr [(N)+3].U.K.flag17) ! #define Flag149(N) (Nodes_Ptr [(N)+3].U.K.flag18) ! #define Flag150(N) (Nodes_Ptr [(N)+3].U.K.pflag1) ! #define Flag151(N) (Nodes_Ptr [(N)+3].U.K.pflag2) ! #define Flag152(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag152) ! #define Flag153(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag153) ! #define Flag154(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag154) ! #define Flag155(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag155) ! #define Flag156(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag156) ! #define Flag157(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag157) ! #define Flag158(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag158) ! #define Flag159(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag159) ! #define Flag160(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag160) ! #define Flag161(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag161) ! #define Flag162(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag162) ! #define Flag163(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag163) ! #define Flag164(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag164) ! #define Flag165(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag165) ! #define Flag166(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag166) ! #define Flag167(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag167) ! #define Flag168(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag168) ! #define Flag169(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag169) ! #define Flag170(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag170) ! #define Flag171(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag171) ! #define Flag172(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag172) ! #define Flag173(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag173) ! #define Flag174(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag174) ! #define Flag175(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag175) ! #define Flag176(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag176) ! #define Flag177(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag177) ! #define Flag178(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag178) ! #define Flag179(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag179) ! #define Flag180(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag180) ! #define Flag181(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag181) ! #define Flag182(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag182) ! #define Flag183(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag183) --- 391,604 ---- #define Str3(N) Field3 (N) ! #define Uint3(N) ((Field3 (N) == 0) ? Uint_0 : Field3 (N)) ! #define Uint4(N) ((Field4 (N) == 0) ? Uint_0 : Field4 (N)) ! #define Uint5(N) ((Field5 (N) == 0) ? Uint_0 : Field5 (N)) ! #define Uint8(N) ((Field8 (N) == 0) ? Uint_0 : Field8 (N)) ! #define Uint9(N) ((Field9 (N) == 0) ? Uint_0 : Field9 (N)) ! #define Uint10(N) ((Field10 (N) == 0) ? Uint_0 : Field10 (N)) ! #define Uint11(N) ((Field11 (N) == 0) ? Uint_0 : Field11 (N)) ! #define Uint12(N) ((Field12 (N) == 0) ? Uint_0 : Field12 (N)) ! #define Uint13(N) ((Field13 (N) == 0) ? Uint_0 : Field13 (N)) ! #define Uint14(N) ((Field14 (N) == 0) ? Uint_0 : Field14 (N)) ! #define Uint15(N) ((Field15 (N) == 0) ? Uint_0 : Field15 (N)) ! #define Uint16(N) ((Field16 (N) == 0) ? Uint_0 : Field16 (N)) ! #define Uint17(N) ((Field17 (N) == 0) ? Uint_0 : Field17 (N)) ! #define Uint22(N) ((Field22 (N) == 0) ? Uint_0 : Field22 (N)) #define Ureal3(N) Field3 (N) #define Ureal18(N) Field18 (N) #define Ureal21(N) Field21 (N) ! #define Analyzed(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.analyzed) ! #define Comes_From_Source(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.c_f_s) ! #define Error_Posted(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.error_posted) ! #define Convention(N) \ ! (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention) ! #define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4) ! #define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5) ! #define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6) ! #define Flag7(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag7) ! #define Flag8(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag8) ! #define Flag9(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag9) ! #define Flag10(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag10) ! #define Flag11(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag11) ! #define Flag12(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag12) ! #define Flag13(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag13) ! #define Flag14(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag14) ! #define Flag15(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag15) ! #define Flag16(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag16) ! #define Flag17(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag17) ! #define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18) ! #define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list) ! #define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_sub) ! #define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins) ! #define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed) ! #define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s) ! #define Flag24(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.error_posted) ! #define Flag25(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag4) ! #define Flag26(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag5) ! #define Flag27(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag6) ! #define Flag28(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag7) ! #define Flag29(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag8) ! #define Flag30(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag9) ! #define Flag31(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag10) ! #define Flag32(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag11) ! #define Flag33(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag12) ! #define Flag34(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag13) ! #define Flag35(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag14) ! #define Flag36(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag15) ! #define Flag37(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag16) ! #define Flag38(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag17) ! #define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18) ! #define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list) ! #define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_sub) ! #define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins) ! #define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed) ! #define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s) ! #define Flag45(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.error_posted) ! #define Flag46(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag4) ! #define Flag47(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag5) ! #define Flag48(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag6) ! #define Flag49(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag7) ! #define Flag50(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag8) ! #define Flag51(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag9) ! #define Flag52(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag10) ! #define Flag53(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag11) ! #define Flag54(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag12) ! #define Flag55(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag13) ! #define Flag56(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag14) ! #define Flag57(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag15) ! #define Flag58(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag16) ! #define Flag59(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag17) ! #define Flag60(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag18) ! #define Flag61(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag1) ! #define Flag62(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag2) ! #define Flag63(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag1) ! #define Flag64(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag2) ! #define Flag65(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag65) ! #define Flag66(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag66) ! #define Flag67(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag67) ! #define Flag68(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag68) ! #define Flag69(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag69) ! #define Flag70(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag70) ! #define Flag71(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag71) ! #define Flag72(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag72) ! #define Flag73(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag73) ! #define Flag74(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag74) ! #define Flag75(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag75) ! #define Flag76(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag76) ! #define Flag77(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag77) ! #define Flag78(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag78) ! #define Flag79(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag79) ! #define Flag80(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag80) ! #define Flag81(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag81) ! #define Flag82(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag82) ! #define Flag83(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag83) ! #define Flag84(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag84) ! #define Flag85(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag85) ! #define Flag86(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag86) ! #define Flag87(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag87) ! #define Flag88(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag88) ! #define Flag89(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag89) ! #define Flag90(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag90) ! #define Flag91(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag91) ! #define Flag92(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag92) ! #define Flag93(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag93) ! #define Flag94(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag94) ! #define Flag95(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag95) ! #define Flag96(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag96) ! #define Flag97(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag97) ! #define Flag98(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag98) ! #define Flag99(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag99) ! #define Flag100(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag100) ! #define Flag101(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag101) ! #define Flag102(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag102) ! #define Flag103(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag103) ! #define Flag104(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag104) ! #define Flag105(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag105) ! #define Flag106(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag106) ! #define Flag107(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag107) ! #define Flag108(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag108) ! #define Flag109(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag109) ! #define Flag110(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag110) ! #define Flag111(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag111) ! #define Flag112(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag112) ! #define Flag113(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag113) ! #define Flag114(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag114) ! #define Flag115(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag115) ! #define Flag116(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag116) ! #define Flag117(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag117) ! #define Flag118(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag118) ! #define Flag119(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag119) ! #define Flag120(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag120) ! #define Flag121(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag121) ! #define Flag122(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag122) ! #define Flag123(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag123) ! #define Flag124(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag124) ! #define Flag125(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag125) ! #define Flag126(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag126) ! #define Flag127(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag127) ! #define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128) ! #define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list) ! #define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_sub) ! #define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins) ! #define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed) ! #define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s) ! #define Flag134(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.error_posted) ! #define Flag135(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag4) ! #define Flag136(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag5) ! #define Flag137(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag6) ! #define Flag138(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag7) ! #define Flag139(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag8) ! #define Flag140(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag9) ! #define Flag141(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag10) ! #define Flag142(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag11) ! #define Flag143(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag12) ! #define Flag144(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag13) ! #define Flag145(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag14) ! #define Flag146(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag15) ! #define Flag147(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag16) ! #define Flag148(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag17) ! #define Flag149(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag18) ! #define Flag150(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag1) ! #define Flag151(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag2) ! #define Flag152(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag152) ! #define Flag153(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag153) ! #define Flag154(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag154) ! #define Flag155(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag155) ! #define Flag156(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag156) ! #define Flag157(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag157) ! #define Flag158(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag158) ! #define Flag159(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag159) ! #define Flag160(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag160) ! #define Flag161(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag161) ! #define Flag162(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag162) ! #define Flag163(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag163) ! #define Flag164(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag164) ! #define Flag165(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag165) ! #define Flag166(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag166) ! #define Flag167(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag167) ! #define Flag168(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag168) ! #define Flag169(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag169) ! #define Flag170(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag170) ! #define Flag171(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag171) ! #define Flag172(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag172) ! #define Flag173(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag173) ! #define Flag174(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag174) ! #define Flag175(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag175) ! #define Flag176(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag176) ! #define Flag177(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag177) ! #define Flag178(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag178) ! #define Flag179(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag179) ! #define Flag180(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag180) ! #define Flag181(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag181) ! #define Flag182(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag182) ! #define Flag183(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag183) diff -Nrc3pad gcc-3.2.3/gcc/ada/a-unccon.ads gcc-3.3/gcc/ada/a-unccon.ads *** gcc-3.2.3/gcc/ada/a-unccon.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-unccon.ads 2002-03-14 10:58:59.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-uncdea.ads gcc-3.3/gcc/ada/a-uncdea.ads *** gcc-3.2.3/gcc/ada/a-uncdea.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-uncdea.ads 2002-03-14 10:58:59.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/aux-io.c gcc-3.3/gcc/ada/aux-io.c *** gcc-3.2.3/gcc/ada/aux-io.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/aux-io.c 2002-10-23 08:04:17.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + /**************************************************************************** + * * + * GNAT RUN-TIME COMPONENTS * + * * + * A - T R A N S * + * * + * 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. * + * * + ****************************************************************************/ + + #include + + #ifdef IN_RTS + #include "tconfig.h" + #include "tsystem.h" + #else + #include "config.h" + #include "system.h" + #endif + + /* 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; + } + + #ifndef SEEK_SET /* Symbolic constants for the "fseek" function: */ + #define SEEK_SET 0 /* Set file pointer to offset */ + #define SEEK_CUR 1 /* Set file pointer to its current value plus offset */ + #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); + } diff -Nrc3pad gcc-3.2.3/gcc/ada/a-witeio.adb gcc-3.3/gcc/ada/a-witeio.adb *** gcc-3.2.3/gcc/ada/a-witeio.adb 2002-05-04 03:27:29.000000000 +0000 --- gcc-3.3/gcc/ada/a-witeio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Ada.Wide_Text_IO is *** 88,93 **** --- 87,94 ---- (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin return new Wide_Text_AFCB; end AFCB_Allocate; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-witeio.ads gcc-3.3/gcc/ada/a-witeio.ads *** gcc-3.2.3/gcc/ada/a-witeio.ads 2002-05-04 03:27:29.000000000 +0000 --- gcc-3.3/gcc/ada/a-witeio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtcoau.adb gcc-3.3/gcc/ada/a-wtcoau.adb *** gcc-3.2.3/gcc/ada/a-wtcoau.adb 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtcoau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtcoau.ads gcc-3.3/gcc/ada/a-wtcoau.ads *** gcc-3.2.3/gcc/ada/a-wtcoau.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtcoau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtcoio.adb gcc-3.3/gcc/ada/a-wtcoio.adb *** gcc-3.2.3/gcc/ada/a-wtcoio.adb 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtcoio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtcoio.ads gcc-3.3/gcc/ada/a-wtcoio.ads *** gcc-3.2.3/gcc/ada/a-wtcoio.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtcoio.ads 2002-03-14 10:58:59.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtcstr.adb gcc-3.3/gcc/ada/a-wtcstr.adb *** gcc-3.2.3/gcc/ada/a-wtcstr.adb 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtcstr.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtcstr.ads gcc-3.3/gcc/ada/a-wtcstr.ads *** gcc-3.2.3/gcc/ada/a-wtcstr.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtcstr.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtdeau.adb gcc-3.3/gcc/ada/a-wtdeau.adb *** gcc-3.2.3/gcc/ada/a-wtdeau.adb 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtdeau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Ada.Wide_Text_IO.Decimal_Au *** 68,74 **** end if; Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); return Item; end Get_Dec; --- 67,73 ---- end if; Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; end Get_Dec; *************** package body Ada.Wide_Text_IO.Decimal_Au *** 97,103 **** end if; Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); return Item; end Get_LLD; --- 96,102 ---- end if; Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; end Get_LLD; diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtdeau.ads gcc-3.3/gcc/ada/a-wtdeau.ads *** gcc-3.2.3/gcc/ada/a-wtdeau.ads 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtdeau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtdeio.adb gcc-3.3/gcc/ada/a-wtdeio.adb *** gcc-3.2.3/gcc/ada/a-wtdeio.adb 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtdeio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtdeio.ads gcc-3.3/gcc/ada/a-wtdeio.ads *** gcc-3.2.3/gcc/ada/a-wtdeio.ads 2002-05-07 08:22:09.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtdeio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtedit.adb gcc-3.3/gcc/ada/a-wtedit.adb *** gcc-3.2.3/gcc/ada/a-wtedit.adb 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtedit.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtedit.ads gcc-3.3/gcc/ada/a-wtedit.ads *** gcc-3.2.3/gcc/ada/a-wtedit.ads 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtedit.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtenau.adb gcc-3.3/gcc/ada/a-wtenau.adb *** gcc-3.2.3/gcc/ada/a-wtenau.adb 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtenau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Ada.Wide_Text_IO.Enumeratio *** 48,55 **** ----------------------- procedure Store_Char ! (File : File_Type; ! WC : Wide_Character; Buf : out Wide_String; Ptr : in out Integer); -- Store a single character in buffer, checking for overflow. --- 47,53 ---- ----------------------- procedure Store_Char ! (WC : Wide_Character; Buf : out Wide_String; Ptr : in out Integer); -- Store a single character in buffer, checking for overflow. *************** package body Ada.Wide_Text_IO.Enumeratio *** 59,65 **** -- least in the OS/2 version. function To_Lower (C : Character) return Character; - function To_Upper (C : Character) return Character; ------------------ -- Get_Enum_Lit -- --- 57,62 ---- *************** package body Ada.Wide_Text_IO.Enumeratio *** 83,89 **** if ch = Character'Pos (''') then Get (File, WC); ! Store_Char (File, WC, Buf, Buflen); ch := Nextc (TFT (File)); --- 80,86 ---- if ch = Character'Pos (''') then Get (File, WC); ! Store_Char (WC, Buf, Buflen); ch := Nextc (TFT (File)); *************** package body Ada.Wide_Text_IO.Enumeratio *** 92,98 **** end if; Get (File, WC); ! Store_Char (File, WC, Buf, Buflen); ch := Nextc (TFT (File)); --- 89,95 ---- end if; Get (File, WC); ! Store_Char (WC, Buf, Buflen); ch := Nextc (TFT (File)); *************** package body Ada.Wide_Text_IO.Enumeratio *** 101,107 **** end if; Get (File, WC); ! Store_Char (File, WC, Buf, Buflen); -- Similarly for identifiers, read as far as we can, in particular, -- do read a trailing underscore (again see ACVC test CE3905L to --- 98,104 ---- end if; Get (File, WC); ! Store_Char (WC, Buf, Buflen); -- Similarly for identifiers, read as far as we can, in particular, -- do read a trailing underscore (again see ACVC test CE3905L to *************** package body Ada.Wide_Text_IO.Enumeratio *** 121,127 **** loop Get (File, WC); ! Store_Char (File, WC, Buf, Buflen); ch := Nextc (TFT (File)); --- 118,124 ---- loop Get (File, WC); ! Store_Char (WC, Buf, Buflen); ch := Nextc (TFT (File)); *************** package body Ada.Wide_Text_IO.Enumeratio *** 328,335 **** ---------------- procedure Store_Char ! (File : File_Type; ! WC : Wide_Character; Buf : out Wide_String; Ptr : in out Integer) is --- 325,331 ---- ---------------- procedure Store_Char ! (WC : Wide_Character; Buf : out Wide_String; Ptr : in out Integer) is *************** package body Ada.Wide_Text_IO.Enumeratio *** 355,371 **** end if; end To_Lower; - -------------- - -- To_Upper -- - -------------- - - 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.Wide_Text_IO.Enumeration_Aux; --- 351,354 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtenau.ads gcc-3.3/gcc/ada/a-wtenau.ads *** gcc-3.2.3/gcc/ada/a-wtenau.ads 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtenau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtenio.adb gcc-3.3/gcc/ada/a-wtenio.adb *** gcc-3.2.3/gcc/ada/a-wtenio.adb 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtenio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtenio.ads gcc-3.3/gcc/ada/a-wtenio.ads *** gcc-3.2.3/gcc/ada/a-wtenio.ads 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtenio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtfiio.adb gcc-3.3/gcc/ada/a-wtfiio.adb *** gcc-3.2.3/gcc/ada/a-wtfiio.adb 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtfiio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtfiio.ads gcc-3.3/gcc/ada/a-wtfiio.ads *** gcc-3.2.3/gcc/ada/a-wtfiio.ads 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtfiio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtflau.adb gcc-3.3/gcc/ada/a-wtflau.adb *** gcc-3.2.3/gcc/ada/a-wtflau.adb 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtflau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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- -- *************** package body Ada.Wide_Text_IO.Float_Aux *** 63,69 **** Item := Scan_Real (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get; ---------- --- 62,68 ---- Item := Scan_Real (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get; ---------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtflau.ads gcc-3.3/gcc/ada/a-wtflau.ads *** gcc-3.2.3/gcc/ada/a-wtflau.ads 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtflau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtflio.adb gcc-3.3/gcc/ada/a-wtflio.adb *** gcc-3.2.3/gcc/ada/a-wtflio.adb 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtflio.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtflio.ads gcc-3.3/gcc/ada/a-wtflio.ads *** gcc-3.2.3/gcc/ada/a-wtflio.ads 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtflio.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtgeau.adb gcc-3.3/gcc/ada/a-wtgeau.adb *** gcc-3.2.3/gcc/ada/a-wtgeau.adb 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtgeau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** package body Ada.Wide_Text_IO.Generic_Au *** 48,55 **** ------------------------ procedure Check_End_Of_Field ! (File : File_Type; ! Buf : String; Stop : Integer; Ptr : Integer; Width : Field) --- 47,53 ---- ------------------------ procedure Check_End_Of_Field ! (Buf : String; Stop : Integer; Ptr : Integer; Width : Field) diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtgeau.ads gcc-3.3/gcc/ada/a-wtgeau.ads *** gcc-3.2.3/gcc/ada/a-wtgeau.ads 2002-05-04 03:27:30.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtgeau.ads 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.3.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package Ada.Wide_Text_IO.Generic_Aux is *** 52,59 **** -- so one of these two routines must be called first. procedure Check_End_Of_Field ! (File : File_Type; ! Buf : String; Stop : Integer; Ptr : Integer; Width : Field); --- 51,57 ---- -- so one of these two routines must be called first. procedure Check_End_Of_Field ! (Buf : String; Stop : Integer; Ptr : Integer; Width : Field); diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtinau.adb gcc-3.3/gcc/ada/a-wtinau.adb *** gcc-3.2.3/gcc/ada/a-wtinau.adb 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtinau.adb 2002-10-23 07:33:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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- -- *************** package body Ada.Wide_Text_IO.Integer_Au *** 80,86 **** end if; Item := Scan_Integer (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get_Int; ------------- --- 79,85 ---- end if; Item := Scan_Integer (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_Int; ------------- *************** package body Ada.Wide_Text_IO.Integer_Au *** 105,111 **** end if; Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get_LLI; -------------- --- 104,110 ---- end if; Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_LLI; -------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtinau.ads gcc-3.3/gcc/ada/a-wtinau.ads *** gcc-3.2.3/gcc/ada/a-wtinau.ads 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtinau.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtinio.adb gcc-3.3/gcc/ada/a-wtinio.adb *** gcc-3.2.3/gcc/ada/a-wtinio.adb 2002-05-04 03:27:31.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtinio.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtinio.ads gcc-3.3/gcc/ada/a-wtinio.ads *** gcc-3.2.3/gcc/ada/a-wtinio.ads 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtinio.ads 2002-03-14 10:59:00.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtmoau.adb gcc-3.3/gcc/ada/a-wtmoau.adb *** gcc-3.2.3/gcc/ada/a-wtmoau.adb 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtmoau.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Ada.Wide_Text_IO.Modular_Au *** 82,88 **** end if; Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get_LLU; ------------- --- 81,87 ---- end if; Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_LLU; ------------- *************** package body Ada.Wide_Text_IO.Modular_Au *** 107,113 **** end if; Item := Scan_Unsigned (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (File, Buf, Stop, Ptr, Width); end Get_Uns; -------------- --- 106,112 ---- end if; Item := Scan_Unsigned (Buf, Ptr'Access, Stop); ! Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_Uns; -------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtmoau.ads gcc-3.3/gcc/ada/a-wtmoau.ads *** gcc-3.2.3/gcc/ada/a-wtmoau.ads 2002-05-07 08:22:10.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtmoau.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtmoio.adb gcc-3.3/gcc/ada/a-wtmoio.adb *** gcc-3.2.3/gcc/ada/a-wtmoio.adb 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtmoio.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wtmoio.ads gcc-3.3/gcc/ada/a-wtmoio.ads *** gcc-3.2.3/gcc/ada/a-wtmoio.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/a-wtmoio.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wttest.adb gcc-3.3/gcc/ada/a-wttest.adb *** gcc-3.2.3/gcc/ada/a-wttest.adb 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/a-wttest.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/a-wttest.ads gcc-3.3/gcc/ada/a-wttest.ads *** gcc-3.2.3/gcc/ada/a-wttest.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/a-wttest.ads 2002-03-14 10:59:01.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/back_end.adb gcc-3.3/gcc/ada/back_end.adb *** gcc-3.2.3/gcc/ada/back_end.adb 2002-05-04 03:27:33.000000000 +0000 --- gcc-3.3/gcc/ada/back_end.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** *** 26,51 **** -- -- ------------------------------------------------------------------------------ ! with Atree; use Atree; ! with Debug; use Debug; ! with Elists; use Elists; ! with Lib; use Lib; ! with Osint; use Osint; ! with Opt; use Opt; ! with Osint; use Osint; ! with Namet; use Namet; ! with Nlists; use Nlists; ! with Stand; use Stand; ! with Sinput; use Sinput; ! with Stringt; use Stringt; ! with Switch; use Switch; ! with System; use System; ! with Types; use Types; package body Back_End is - -- Local subprograms - ------------------- -- Call_Back_End -- ------------------- --- 25,50 ---- -- -- ------------------------------------------------------------------------------ ! with Atree; use Atree; ! with Debug; use Debug; ! with Elists; use Elists; ! with Lib; use Lib; ! with Osint; use Osint; ! with Opt; use Opt; ! with Osint; use Osint; ! with Osint.C; use Osint.C; ! with Namet; use Namet; ! with Nlists; use Nlists; ! with Stand; use Stand; ! with Sinput; use Sinput; ! with Stringt; use Stringt; ! with Switch; use Switch; ! with Switch.C; use Switch.C; ! with System; use System; ! with Types; use Types; package body Back_End is ------------------- -- Call_Back_End -- ------------------- *************** package body Back_End is *** 209,225 **** Last := Last - 1; end if; if Switch_Chars (First .. Last) = "o" or else Switch_Chars (First .. Last) = "dumpbase" then Next_Arg := Next_Arg + 1; elsif Switch_Chars (First .. Last) = "quiet" then ! null; -- do not record this switch else -- Store any other GCC switches Store_Compilation_Switch (Switch_Chars); end if; end Scan_Back_End_Switches; --- 208,230 ---- Last := Last - 1; end if; + -- For dumpbase and o, skip following argument and do not + -- store either the switch or the following argument + if Switch_Chars (First .. Last) = "o" or else Switch_Chars (First .. Last) = "dumpbase" then Next_Arg := Next_Arg + 1; + -- Do not record -quiet switch + elsif Switch_Chars (First .. Last) = "quiet" then ! null; else -- Store any other GCC switches + Store_Compilation_Switch (Switch_Chars); end if; end Scan_Back_End_Switches; *************** package body Back_End is *** 259,273 **** elsif not Is_Switch (Argv) then -- must be a file name Add_File (Argv); ! elsif Is_Front_End_Switch (Argv) then ! Scan_Front_End_Switches (Argv); ! -- ??? Should be done in Scan_Front_End_Switches, after ! -- Switch is splitted in compiler/make/bind units ! if Argv (2) /= 'I' then ! Store_Compilation_Switch (Argv); ! end if; -- All non-front-end switches are back-end switches --- 264,278 ---- elsif not Is_Switch (Argv) then -- must be a file name Add_File (Argv); ! -- We must recognize -nostdinc to suppress visibility on the ! -- standard GNAT RTL sources. This is also a gcc switch. ! elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdinc" then ! Opt.No_Stdinc := True; ! Scan_Back_End_Switches (Argv); ! elsif Is_Front_End_Switch (Argv) then ! Scan_Front_End_Switches (Argv); -- All non-front-end switches are back-end switches diff -Nrc3pad gcc-3.2.3/gcc/ada/back_end.ads gcc-3.3/gcc/ada/back_end.ads *** gcc-3.2.3/gcc/ada/back_end.ads 2002-05-04 03:27:33.000000000 +0000 --- gcc-3.3/gcc/ada/back_end.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/bcheck.adb gcc-3.3/gcc/ada/bcheck.adb *** gcc-3.2.3/gcc/ada/bcheck.adb 2002-05-04 03:27:33.000000000 +0000 --- gcc-3.3/gcc/ada/bcheck.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with ALI.Util; use ALI.Util; *** 31,37 **** with Binderr; use Binderr; with Butil; use Butil; with Casing; use Casing; - with Debug; use Debug; with Fname; use Fname; with Namet; use Namet; with Opt; use Opt; --- 30,35 ---- *************** package body Bcheck is *** 359,440 **** -- Second, all units are verified against the specified restrictions. procedure Check_Partition_Restrictions is ! R : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id); ! -- Record the first unit specifying each partition restriction ! ! V : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id); ! -- Record the last unit violating each partition restriction ! ! procedure List_Applicable_Restrictions; ! -- Output a list of restrictions that may be applied to the partition, ! -- without causing bind errors. ! ! ---------------------------------- ! -- List_Applicable_Restrictions -- ! ---------------------------------- ! ! procedure List_Applicable_Restrictions is ! Additional_Restrictions_Listed : Boolean := False; ! begin ! -- List any restrictions which were not violated and not specified ! for J in Partition_Restrictions loop ! if V (J) = No_ALI_Id and R (J) = No_ALI_Id then ! if not Additional_Restrictions_Listed then ! Write_Str ("The following additional restrictions may be" & ! " applied to this partition:"); ! Write_Eol; ! Additional_Restrictions_Listed := True; ! end if; ! Write_Str ("pragma Restrictions ("); ! declare ! S : constant String := Restriction_Id'Image (J); ! begin ! Name_Len := S'Length; ! Name_Buffer (1 .. Name_Len) := S; ! end; ! Set_Casing (Mixed_Case); ! Write_Str (Name_Buffer (1 .. Name_Len)); ! Write_Str (");"); ! Write_Eol; ! end if; ! end loop; ! end List_Applicable_Restrictions; ! -- Start of processing for Check_Partition_Restrictions begin ! Find_Restrictions : for A in ALIs.First .. ALIs.Last loop ! for J in Partition_Restrictions loop if R (J) = No_ALI_Id and ALIs.Table (A).Restrictions (J) = 'r' then R (J) := A; end if; end loop; ! end loop Find_Restrictions; - Find_Violations : for A in ALIs.First .. ALIs.Last loop ! for J in Partition_Restrictions loop if ALIs.Table (A).Restrictions (J) = 'v' and then not Is_Internal_File_Name (ALIs.Table (A).Sfile) then ! -- A violation of a restriction was found, so check whether ! -- that restriction was actually in effect. If so, give an ! -- error message. ! ! -- Note that all such violations found are reported. V (J) := A; ! if R (J) /= No_ALI_Id then ! Report_Violated_Restriction : declare M1 : constant String := "% has Restriction ("; S : constant String := Restriction_Id'Image (J); M2 : String (1 .. M1'Length + S'Length + 1); --- 357,427 ---- -- 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 ! No_Implicit_Dynamic_Code => True, ! -- This could modify and pessimize generated code ! No_Implicit_Loops => True, ! -- This could modify and pessimize generated code ! No_Recursion => True, ! -- Not checkable at compile time ! No_Reentrancy => True, ! -- Not checkable at compile time ! others => False); ! -- Define those restrictions that should be output if the gnatbind -r ! -- switch is used. Not all restrictions are output for the reasons given ! -- above in the list, and this array is used to test whether the ! -- corresponding pragma should be listed. True means that it should not ! -- be listed. ! R : array (All_Restrictions) of ALI_Id := (others => No_ALI_Id); ! -- Record the first unit specifying each compilation unit restriction ! V : array (All_Restrictions) of ALI_Id := (others => No_ALI_Id); ! -- Record the last unit violating each partition restriction. Note ! -- that entries in this array that do not correspond to partition ! -- restrictions can never be modified. ! Additional_Restrictions_Listed : Boolean := False; ! -- Set True if we have listed header for restrictions begin ! -- Loop to find restrictions ! for A in ALIs.First .. ALIs.Last loop ! for J in All_Restrictions loop if R (J) = No_ALI_Id and ALIs.Table (A).Restrictions (J) = 'r' then R (J) := A; end if; end loop; ! end loop; ! ! -- Loop to find violations for A in ALIs.First .. ALIs.Last loop ! for J in All_Restrictions loop if ALIs.Table (A).Restrictions (J) = 'v' and then not Is_Internal_File_Name (ALIs.Table (A).Sfile) then ! -- A violation of a restriction was found V (J) := A; ! -- If this is a paritition restriction, and the restriction ! -- was specified in some unit in the partition, then this ! -- is a violation of the consistency requirement, so we ! -- generate an appropriate error message. ! ! if R (J) /= No_ALI_Id ! and then J in Partition_Restrictions ! then ! declare M1 : constant String := "% has Restriction ("; S : constant String := Restriction_Id'Image (J); M2 : String (1 .. M1'Length + S'Length + 1); *************** package body Bcheck is *** 455,468 **** Error_Msg_Name_1 := ALIs.Table (A).Sfile; Consistency_Error_Msg ("but file % violates this restriction"); ! end Report_Violated_Restriction; end if; end if; end loop; ! end loop Find_Violations; ! if Debug_Flag_R then ! List_Applicable_Restrictions; end if; end Check_Partition_Restrictions; --- 442,488 ---- Error_Msg_Name_1 := ALIs.Table (A).Sfile; Consistency_Error_Msg ("but file % violates this restriction"); ! end; end if; end if; end loop; ! end loop; ! -- List applicable restrictions if option set ! ! if List_Restrictions then ! ! -- List any restrictions which were not violated and not specified ! ! for J in All_Restrictions loop ! if V (J) = No_ALI_Id ! and then R (J) = No_ALI_Id ! and then not No_Restriction_List (J) ! then ! if not Additional_Restrictions_Listed then ! Write_Eol; ! Write_Line ! ("The following additional restrictions may be" & ! " applied to this partition:"); ! Additional_Restrictions_Listed := True; ! end if; ! ! Write_Str ("pragma Restrictions ("); ! ! declare ! S : constant String := Restriction_Id'Image (J); ! ! begin ! Name_Len := S'Length; ! Name_Buffer (1 .. Name_Len) := S; ! end; ! ! Set_Casing (Mixed_Case); ! Write_Str (Name_Buffer (1 .. Name_Len)); ! Write_Str (");"); ! Write_Eol; ! end if; ! end loop; end if; end Check_Partition_Restrictions; diff -Nrc3pad gcc-3.2.3/gcc/ada/bcheck.ads gcc-3.3/gcc/ada/bcheck.ads *** gcc-3.2.3/gcc/ada/bcheck.ads 2002-05-04 03:27:33.000000000 +0000 --- gcc-3.3/gcc/ada/bcheck.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/binde.adb gcc-3.3/gcc/ada/binde.adb *** gcc-3.2.3/gcc/ada/binde.adb 2002-05-04 03:27:33.000000000 +0000 --- gcc-3.3/gcc/ada/binde.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/binde.ads gcc-3.3/gcc/ada/binde.ads *** gcc-3.2.3/gcc/ada/binde.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/binde.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/binderr.adb gcc-3.3/gcc/ada/binderr.adb *** gcc-3.2.3/gcc/ada/binderr.adb 2002-05-04 03:27:34.000000000 +0000 --- gcc-3.3/gcc/ada/binderr.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/binderr.ads gcc-3.3/gcc/ada/binderr.ads *** gcc-3.2.3/gcc/ada/binderr.ads 2002-05-04 03:27:34.000000000 +0000 --- gcc-3.3/gcc/ada/binderr.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/bindgen.adb gcc-3.3/gcc/ada/bindgen.adb *** gcc-3.2.3/gcc/ada/bindgen.adb 2002-05-04 03:27:34.000000000 +0000 --- gcc-3.3/gcc/ada/bindgen.adb 2002-11-15 01:45:29.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.5.10.2 $ -- -- -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** with Hostparm; *** 37,46 **** with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Types; use Types; with Sdefault; use Sdefault; - with System; use System; with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; --- 36,45 ---- with Namet; use Namet; with Opt; use Opt; 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; *************** package body Bindgen is *** 63,83 **** Num_Elab_Calls : Nat := 0; -- Number of generated calls to elaboration routines - subtype chars_ptr is Address; - ----------------------- -- Local Subprograms -- ----------------------- ! procedure WBI (Info : String) renames Osint.Write_Binder_Info; -- Convenient shorthand used throughout - function ABE_Boolean_Required (U : Unit_Id) return Boolean; - -- Given a unit id value U, determines if the corresponding unit requires - -- an access-before-elaboration check variable, i.e. it is a non-predefined - -- body for which no pragma Elaborate, Elaborate_All or Elaborate_Body is - -- present, and thus could require ABE checks. - 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 --- 62,74 ---- Num_Elab_Calls : Nat := 0; -- Number of generated calls to elaboration routines ----------------------- -- Local Subprograms -- ----------------------- ! 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 *************** package body Bindgen is *** 162,170 **** function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; -- Compare linker options, when sorting, first according to ! -- Is_Internal_File (internal files come later) and then by elaboration ! -- order position (latest to earliest) except its not possible to ! -- distinguish between a linker option in the spec and one in the body. procedure Move_Linker_Option (From : Natural; To : Natural); -- Move routine for sorting linker options --- 153,160 ---- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; -- Compare linker options, when sorting, first according to ! -- Is_Internal_File (internal files come later) and then by ! -- elaboration order position (latest to earliest). procedure Move_Linker_Option (From : Natural; To : Natural); -- Move routine for sorting linker options *************** package body Bindgen is *** 204,212 **** -- If Last is greater than or equal to N, no effect, otherwise store -- blanks in Statement_Buffer bumping Last, until Last = N. - function Value (chars : chars_ptr) return String; - -- Return C NUL-terminated string at chars as an Ada string - procedure Write_Info_Ada_C (Ada : String; C : String; Common : String); -- For C code case, write C & Common, for Ada case write Ada & Common -- to current binder output file using Write_Binder_Info. --- 194,199 ---- *************** package body Bindgen is *** 218,248 **** -- First writes its argument (using Set_String (S)), then writes out the -- contents of statement buffer up to Last, and reset Last to 0 - -------------------------- - -- ABE_Boolean_Required -- - -------------------------- - - function ABE_Boolean_Required (U : Unit_Id) return Boolean is - Typ : constant Unit_Type := Units.Table (U).Utype; - Unit : Unit_Id; - - begin - if Typ /= Is_Body then - return False; - - else - Unit := U + 1; - - return (not Units.Table (Unit).Pure) - and then - (not Units.Table (Unit).Preelab) - and then - (not Units.Table (Unit).Elaborate_Body) - and then - (not Units.Table (Unit).Predefined); - end if; - end ABE_Boolean_Required; - ---------------------- -- Gen_Adafinal_Ada -- ---------------------- --- 205,210 ---- *************** package body Bindgen is *** 283,288 **** --- 245,251 ---- procedure Gen_Adainit_Ada is Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; + begin WBI (" procedure " & Ada_Init_Name.all & " is"); *************** package body Bindgen is *** 339,355 **** Write_Statement_Buffer; ! -- 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. if No_Run_Time_Specified then - - -- 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 Main_Priority /= No_Main_Priority then WBI (" Main_Priority : Integer;"); WBI (" pragma Import (C, Main_Priority," & --- 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," & *************** package body Bindgen is *** 369,376 **** --- 326,351 ---- 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. + else + -- Generate restrictions string + + Set_String (" Restrictions : constant String :="); + Write_Statement_Buffer; + Set_String (" """); + + for J in Restrictions'Range loop + Set_Char (Restrictions (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; WBI (""); + WBI (" procedure Set_Globals"); WBI (" (Main_Priority : Integer;"); WBI (" Time_Slice_Value : Integer;"); *************** package body Bindgen is *** 378,392 **** WBI (" Locking_Policy : Character;"); WBI (" Queuing_Policy : Character;"); WBI (" Task_Dispatching_Policy : Character;"); ! WBI (" Adafinal : System.Address;"); WBI (" Unreserve_All_Interrupts : Integer;"); ! WBI (" Exception_Tracebacks : Integer);"); WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");"); - WBI (""); -- Import entry point for elaboration time signal handler -- installation, and indication of whether it's been called -- previously WBI (""); WBI (" procedure Install_Handler;"); WBI (" pragma Import (C, Install_Handler, " & --- 353,368 ---- WBI (" Locking_Policy : Character;"); 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;"); WBI (" pragma Import (C, Install_Handler, " & *************** package body Bindgen is *** 442,448 **** Set_String ("',"); Write_Statement_Buffer; ! WBI (" Adafinal => System.Null_Address,"); Set_String (" Unreserve_All_Interrupts => "); --- 418,424 ---- Set_String ("',"); Write_Statement_Buffer; ! WBI (" Restrictions => Restrictions'Address,"); Set_String (" Unreserve_All_Interrupts => "); *************** package body Bindgen is *** 463,468 **** --- 439,455 ---- Set_String ("0"); end if; + Set_String (","); + Write_Statement_Buffer; + + Set_String (" Zero_Cost_Exceptions => "); + + if Zero_Cost_Exceptions_Specified then + Set_String ("1"); + else + Set_String ("0"); + end if; + Set_String (");"); Write_Statement_Buffer; *************** package body Bindgen is *** 484,489 **** --- 471,477 ---- procedure Gen_Adainit_C is Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; + begin WBI ("void " & Ada_Init_Name.all & " ()"); WBI ("{"); *************** package body Bindgen is *** 508,513 **** --- 496,503 ---- 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 *************** package body Bindgen is *** 520,526 **** --- 510,529 ---- Write_Statement_Buffer; end if; + -- Normal case (run time present) + else + -- Generate definition for restrictions string + + Set_String (" const char *restrictions = """); + + for J in Restrictions'Range loop + Set_Char (Restrictions (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; + -- Code for normal case (not in No_Run_Time mode) Gen_Exception_Table_C; *************** package body Bindgen is *** 553,611 **** end if; Set_Char (','); ! Tab_To (15); Set_String ("/* Time_Slice_Value */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (ALIs.Table (ALIs.First).WC_Encoding); Set_String ("',"); ! Tab_To (15); Set_String ("/* WC_Encoding */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Locking_Policy_Specified); Set_String ("',"); ! Tab_To (15); Set_String ("/* Locking_Policy */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Queuing_Policy_Specified); Set_String ("',"); ! Tab_To (15); Set_String ("/* Queuing_Policy */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Task_Dispatching_Policy_Specified); Set_String ("',"); ! Tab_To (15); Set_String ("/* Tasking_Dispatching_Policy */"); Write_Statement_Buffer; Set_String (" "); ! Set_String ("0,"); ! Tab_To (15); ! Set_String ("/* Finalization routine address, not used anymore */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); Set_String (","); ! Tab_To (15); Set_String ("/* Unreserve_All_Interrupts */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Exception_Tracebacks)); ! Set_String (");"); ! Tab_To (15); Set_String ("/* Exception_Tracebacks */"); Write_Statement_Buffer; -- Install elaboration time signal handler WBI (" if (__gnat_handler_installed == 0)"); WBI (" {"); WBI (" __gnat_install_handler ();"); --- 556,623 ---- 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 + WBI (" if (__gnat_handler_installed == 0)"); WBI (" {"); WBI (" __gnat_install_handler ();"); *************** package body Bindgen is *** 635,651 **** -- and spec are different and we are currently processing -- the body, in which case it is the spec (Unum + 1). - procedure Set_Elab_Entity; - -- Set name of elaboration entity flag - - procedure Set_Elab_Entity is - begin - Get_Decoded_Name_String_With_Brackets (U.Uname); - Name_Len := Name_Len - 2; - Set_Casing (U.Icasing); - Set_Name_Buffer; - end Set_Elab_Entity; - begin if U.Utype = Is_Body then Unum_Spec := Unum + 1; --- 647,652 ---- *************** package body Bindgen is *** 1169,1175 **** procedure Gen_Main_Ada is Target : constant String_Ptr := Target_Name; VxWorks_Target : constant Boolean := ! Target (Target'Last - 7 .. Target'Last) = "vxworks/"; begin WBI (""); --- 1170,1177 ---- 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 (""); *************** package body Bindgen is *** 1237,1242 **** --- 1239,1257 ---- WBI (""); end if; + -- Generate a reference to 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 + (" Ensure_Reference : System.Address := " & + "Ada_Main_Program_Name'Address;"); + WBI (""); + end if; + WBI (" begin"); -- On VxWorks, there are no command line arguments *************** package body Bindgen is *** 1311,1317 **** procedure Gen_Main_C is Target : constant String_Ptr := Target_Name; VxWorks_Target : constant Boolean := ! Target (Target'Last - 7 .. Target'Last) = "vxworks/"; begin Set_String ("int "); --- 1326,1333 ---- 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 "); *************** package body Bindgen is *** 1347,1352 **** --- 1363,1379 ---- 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; *************** package body Bindgen is *** 1439,1445 **** ------------------------------ procedure Gen_Object_Files_Options is ! Lgnat : Integer; procedure Write_Linker_Option; -- Write binder info linker option. --- 1466,1475 ---- ------------------------------ procedure Gen_Object_Files_Options is ! Lgnat : Natural; ! -- This keeps track of the position in the sorted set of entries ! -- in the Linker_Options table of where the first entry from an ! -- internal file appears. procedure Write_Linker_Option; -- Write binder info linker option. *************** package body Bindgen is *** 1546,1555 **** -- Sort linker options ! Sort (Linker_Options.Last, Move_Linker_Option'Access, ! Lt_Linker_Option'Access); ! -- Write user linker options Lgnat := Linker_Options.Last + 1; --- 1576,1615 ---- -- Sort linker options ! -- This sort accomplishes two important purposes: ! -- a) All application files are sorted to the front, and all ! -- GNAT internal files are sorted to the end. This results ! -- in a well defined dividing line between the two sets of ! -- files, for the purpose of inserting certain standard ! -- library references into the linker arguments list. ! ! -- b) Given two different units, we sort the linker options so ! -- that those from a unit earlier in the elaboration order ! -- comes later in the list. This is a heuristic designed ! -- to create a more friendly order of linker options when ! -- the operations appear in separate units. The idea is that ! -- if unit A must be elaborated before unit B, then it is ! -- more likely that B references libraries included by A, ! -- than vice versa, so we want the libraries included by ! -- A to come after the libraries included by B. ! ! -- These two criteria are implemented by function Lt_Linker_Option. ! -- Note that a special case of b) is that specs are elaborated before ! -- bodies, so linker options from specs come after linker options ! -- for bodies, and again, the assumption is that libraries used by ! -- the body are more likely to reference libraries used by the spec, ! -- than vice versa. ! ! Sort ! (Linker_Options.Last, ! Move_Linker_Option'Access, ! Lt_Linker_Option'Access); ! ! -- Write user linker options, i.e. the set of linker options that ! -- come from all files other than GNAT internal files, Lgnat is ! -- left set to point to the first entry from a GNAT internal file, ! -- or past the end of the entriers if there are no internal files. Lgnat := Linker_Options.Last + 1; *************** package body Bindgen is *** 1563,1570 **** end if; end loop; ! if not (No_Run_Time_Specified or else Opt.No_Stdlib) then Name_Len := 0; if Opt.Shared_Libgnat then --- 1623,1634 ---- end if; end loop; ! -- Now we insert standard linker options that must appear after the ! -- entries from user files, and before the entries from GNAT run-time ! -- 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 *************** package body Bindgen is *** 1573,1579 **** Add_Str_To_Name_Buffer ("-static"); end if; ! -- Write directly to avoid -K output. Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); --- 1637,1643 ---- Add_Str_To_Name_Buffer ("-static"); end if; ! -- Write directly to avoid -K output (why???) Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); *************** package body Bindgen is *** 1592,1601 **** Name_Len := 0; Add_Str_To_Name_Buffer ("-lgnat"); Write_Linker_Option; - end if; ! -- Write internal linker options for J in Lgnat .. Linker_Options.Last loop Get_Name_String (Linker_Options.Table (J).Name); --- 1656,1664 ---- Name_Len := 0; Add_Str_To_Name_Buffer ("-lgnat"); Write_Linker_Option; end if; ! -- Write linker options from all internal files for J in Lgnat .. Linker_Options.Last loop Get_Name_String (Linker_Options.Table (J).Name); *************** package body Bindgen is *** 1616,1623 **** procedure Gen_Output_File (Filename : String) is - -- Start of processing for Gen_Output_File - begin -- Override Ada_Bind_File and Bind_Main_Program for Java since -- JGNAT only supports Ada code, and the main program is already --- 1679,1684 ---- *************** package body Bindgen is *** 1672,1678 **** Target : constant String_Ptr := Target_Name; VxWorks_Target : constant Boolean := ! Target (Target'Last - 7 .. Target'Last) = "vxworks/"; begin -- Create spec first --- 1733,1740 ---- 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 *************** package body Bindgen is *** 1746,1752 **** end if; end if; ! -- Generate the GNAT_Version and Ada_Main_Program_name info only for -- the main program. Otherwise, it can lead under some circumstances -- to a symbol duplication during the link (for instance when a -- C program uses 2 Ada libraries) --- 1808,1814 ---- end if; end if; ! -- Generate the GNAT_Version and Ada_Main_Program_Name info only for -- the main program. Otherwise, it can lead under some circumstances -- to a symbol duplication during the link (for instance when a -- C program uses 2 Ada libraries) *************** package body Bindgen is *** 1931,1938 **** WBI (""); WBI ("extern void __gnat_set_globals "); ! WBI (" PARAMS ((int, int, int, int, int, int, "); ! WBI (" void (*) PARAMS ((void)), int, int));"); WBI ("extern void " & Ada_Final_Name.all & " PARAMS ((void));"); WBI ("extern void " & Ada_Init_Name.all & " PARAMS ((void));"); --- 1993,2000 ---- 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));"); *************** package body Bindgen is *** 2572,2578 **** function Get_Main_Name return String is Target : constant String_Ptr := Target_Name; VxWorks_Target : constant Boolean := ! Target (Target'Last - 7 .. Target'Last) = "vxworks/"; begin -- Explicit name given with -M switch --- 2634,2641 ---- 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 *************** package body Bindgen is *** 2592,2598 **** -- since we can't have dots in a nested program name. Note that -- we do not include the %b at the end of the unit name. ! for J in reverse 1 .. Name_Len - 3 loop if J = 1 or else Name_Buffer (J - 1) = '.' then return Name_Buffer (J .. Name_Len - 2); end if; --- 2655,2661 ---- -- since we can't have dots in a nested program name. Note that -- we do not include the %b at the end of the unit name. ! for J in reverse 1 .. Name_Len - 2 loop if J = 1 or else Name_Buffer (J - 1) = '.' then return Name_Buffer (J .. Name_Len - 2); end if; *************** package body Bindgen is *** 2613,2639 **** function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is begin if Linker_Options.Table (Op1).Internal_File /= Linker_Options.Table (Op2).Internal_File then return Linker_Options.Table (Op1).Internal_File < ! Linker_Options.Table (Op2).Internal_File; else ! if Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position ! /= ! Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position ! then ! return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position ! > ! Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position; - else - return Linker_Options.Table (Op1).Original_Pos - < - Linker_Options.Table (Op2).Original_Pos; - end if; end if; end Lt_Linker_Option; --- 2676,2702 ---- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is begin + -- Sort internal files last + if Linker_Options.Table (Op1).Internal_File /= Linker_Options.Table (Op2).Internal_File then + -- Note: following test uses False < True + return Linker_Options.Table (Op1).Internal_File < ! Linker_Options.Table (Op2).Internal_File; ! ! -- If both internal or both non-internal, sort according to the ! -- elaboration position. A unit that is elaborated later should ! -- come earlier in the linker options list. ! else ! return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position ! > ! Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position; end if; end Lt_Linker_Option; *************** package body Bindgen is *** 2791,2821 **** end loop; end Tab_To; - ----------- - -- Value -- - ----------- - - function Value (chars : chars_ptr) return String is - function Strlen (chars : chars_ptr) return Natural; - pragma Import (C, Strlen); - - begin - if chars = Null_Address then - return ""; - - else - declare - subtype Result_Type is String (1 .. Strlen (chars)); - - Result : Result_Type; - for Result'Address use chars; - - begin - return Result; - end; - end if; - end Value; - ---------------------- -- Write_Info_Ada_C -- ---------------------- --- 2854,2859 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/bindgen.ads gcc-3.3/gcc/ada/bindgen.ads *** gcc-3.2.3/gcc/ada/bindgen.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/bindgen.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/bindusg.adb gcc-3.3/gcc/ada/bindusg.adb *** gcc-3.2.3/gcc/ada/bindusg.adb 2002-05-04 03:27:35.000000000 +0000 --- gcc-3.3/gcc/ada/bindusg.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** with Output; use Output; *** 31,45 **** procedure Bindusg is - procedure Write_Switch_Char; - -- Write two spaces followed by appropriate switch character - - procedure Write_Switch_Char is - begin - Write_Str (" "); - Write_Char (Switch_Character); - end Write_Switch_Char; - -- Start of processing for Bindusg begin --- 30,35 ---- *************** begin *** 54,260 **** -- Line for -aO switch ! Write_Switch_Char; ! Write_Str ("aOdir Specify library files search path"); Write_Eol; -- Line for -aI switch ! Write_Switch_Char; ! Write_Str ("aIdir Specify source files search path"); Write_Eol; -- Line for A switch ! Write_Switch_Char; ! Write_Str ("A Generate binder program in Ada (default)"); Write_Eol; -- Line for -b switch ! Write_Switch_Char; ! Write_Str ("b Generate brief messages to std"); Write_Str ("err even if verbose mode set"); Write_Eol; -- Line for -c switch ! Write_Switch_Char; ! Write_Str ("c Check only, no generation of b"); Write_Str ("inder output file"); Write_Eol; -- Line for C switch ! Write_Switch_Char; ! Write_Str ("C Generate binder program in C"); Write_Eol; -- Line for -e switch ! Write_Switch_Char; ! Write_Str ("e Output complete list of elabor"); Write_Str ("ation order dependencies"); Write_Eol; -- Line for -E switch ! Write_Switch_Char; ! Write_Str ("E Store tracebacks in Exception occurrences"); Write_Eol; -- Line for -h switch ! Write_Switch_Char; ! Write_Str ("h Output this usage (help) infor"); Write_Str ("mation"); Write_Eol; -- Lines for -I switch ! Write_Switch_Char; ! Write_Str ("Idir Specify library and source files search path"); Write_Eol; ! Write_Switch_Char; ! Write_Str ("I- Don't look for sources & library files"); Write_Str (" in default directory"); Write_Eol; -- Line for -K switch ! Write_Switch_Char; ! Write_Str ("K Give list of linker options specified for link"); Write_Eol; -- Line for -l switch ! Write_Switch_Char; ! Write_Str ("l Output chosen elaboration order"); Write_Eol; -- Line of -L switch ! Write_Switch_Char; ! Write_Str ("Lxyz Library build: adainit/final "); Write_Str ("renamed to xyzinit/final, implies -n"); Write_Eol; -- Line for -M switch ! Write_Switch_Char; ! Write_Str ("Mxyz Rename generated main program from main to xyz"); Write_Eol; -- Line for -m switch ! Write_Switch_Char; ! Write_Str ("mnnn Limit number of detected error"); Write_Str ("s to nnn (1-999)"); Write_Eol; -- Line for -n switch ! Write_Switch_Char; ! Write_Str ("n No Ada main program (foreign main routine)"); Write_Eol; -- Line for -nostdinc ! Write_Switch_Char; ! Write_Str ("nostdinc Don't look for source files"); Write_Str (" in the system default directory"); Write_Eol; -- Line for -nostdlib ! Write_Switch_Char; ! Write_Str ("nostdlib Don't look for library files"); Write_Str (" in the system default directory"); Write_Eol; -- Line for -o switch ! Write_Switch_Char; ! Write_Str ("o file Give the output file name (default is b~xxx.adb) "); Write_Eol; -- Line for -O switch ! Write_Switch_Char; ! Write_Str ("O Give list of objects required for link"); Write_Eol; -- Line for -p switch ! Write_Switch_Char; ! Write_Str ("p Pessimistic (worst-case) elaborat"); Write_Str ("ion order"); Write_Eol; -- Line for -s switch ! Write_Switch_Char; ! Write_Str ("s Require all source files to be"); Write_Str (" present"); Write_Eol; -- Line for -Sxx switch ! Write_Switch_Char; ! Write_Str ("S?? Sin/lo/hi/xx for Initialize_Scalars"); Write_Str (" invalid/low/high/hex"); Write_Eol; -- Line for -static ! Write_Switch_Char; ! Write_Str ("static Link against a static GNAT run time"); Write_Eol; -- Line for -shared ! Write_Switch_Char; ! Write_Str ("shared Link against a shared GNAT run time"); Write_Eol; -- Line for -t switch ! Write_Switch_Char; ! Write_Str ("t Tolerate time stamp and other consistency errors"); Write_Eol; -- Line for -T switch ! Write_Switch_Char; ! Write_Str ("Tn Set time slice value to n microseconds (n >= 0)"); Write_Eol; -- Line for -v switch ! Write_Switch_Char; ! Write_Str ("v Verbose mode. Error messages, "); Write_Str ("header, summary output to stdout"); Write_Eol; -- Lines for -w switch ! Write_Switch_Char; ! Write_Str ("wx Warning mode. (x=s/e for supp"); Write_Str ("ress/treat as error)"); Write_Eol; -- Line for -x switch ! Write_Switch_Char; ! Write_Str ("x Exclude source files (check ob"); Write_Str ("ject consistency only)"); Write_Eol; -- Line for -z switch ! Write_Switch_Char; ! Write_Str ("z No main subprogram (zero main)"); Write_Eol; -- Line for sfile --- 44,229 ---- -- Line for -aO switch ! Write_Str (" -aOdir Specify library files search path"); Write_Eol; -- Line for -aI switch ! Write_Str (" -aIdir Specify source files search path"); Write_Eol; -- Line for A switch ! Write_Str (" -A Generate binder program in Ada (default)"); Write_Eol; -- Line for -b switch ! Write_Str (" -b Generate brief messages to std"); Write_Str ("err even if verbose mode set"); Write_Eol; -- Line for -c switch ! Write_Str (" -c Check only, no generation of b"); Write_Str ("inder output file"); Write_Eol; -- Line for C switch ! Write_Str (" -C Generate binder program in C"); Write_Eol; -- Line for -e switch ! Write_Str (" -e Output complete list of elabor"); Write_Str ("ation order dependencies"); Write_Eol; -- Line for -E switch ! Write_Str (" -E Store tracebacks in Exception occurrences"); Write_Eol; -- Line for -h switch ! Write_Str (" -h Output this usage (help) infor"); Write_Str ("mation"); Write_Eol; -- Lines for -I switch ! Write_Str (" -Idir Specify library and source files search path"); Write_Eol; ! Write_Str (" -I- Don't look for sources & library files"); Write_Str (" in default directory"); Write_Eol; -- Line for -K switch ! Write_Str (" -K Give list of linker options specified for link"); Write_Eol; -- Line for -l switch ! Write_Str (" -l Output chosen elaboration order"); Write_Eol; -- Line of -L switch ! Write_Str (" -Lxyz Library build: adainit/final "); Write_Str ("renamed to xyzinit/final, implies -n"); Write_Eol; -- Line for -M switch ! Write_Str (" -Mxyz Rename generated main program from main to xyz"); Write_Eol; -- 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 ! Write_Str (" -n No Ada main program (foreign main routine)"); Write_Eol; -- Line for -nostdinc ! Write_Str (" -nostdinc Don't look for source files"); Write_Str (" in the system default directory"); Write_Eol; -- Line for -nostdlib ! Write_Str (" -nostdlib Don't look for library files"); Write_Str (" in the system default directory"); Write_Eol; -- Line for -o switch ! Write_Str (" -o file Give the output file name (default is b~xxx.adb) "); Write_Eol; -- Line for -O switch ! Write_Str (" -O Give list of objects required for link"); Write_Eol; -- Line for -p switch ! Write_Str (" -p Pessimistic (worst-case) elaborat"); Write_Str ("ion order"); Write_Eol; + -- Line for -r switch + + Write_Str (" -r List restrictions that could be a"); + Write_Str ("pplied to this partition"); + Write_Eol; + -- Line for -s switch ! Write_Str (" -s Require all source files to be"); Write_Str (" present"); Write_Eol; -- Line for -Sxx switch ! Write_Str (" -S?? Sin/lo/hi/xx for Initialize_Scalars"); Write_Str (" invalid/low/high/hex"); Write_Eol; -- Line for -static ! Write_Str (" -static Link against a static GNAT run time"); Write_Eol; -- Line for -shared ! Write_Str (" -shared Link against a shared GNAT run time"); Write_Eol; -- Line for -t switch ! Write_Str (" -t Tolerate time stamp and other consistency errors"); Write_Eol; -- Line for -T switch ! Write_Str (" -Tn Set time slice value to n microseconds (n >= 0)"); Write_Eol; -- Line for -v switch ! Write_Str (" -v Verbose mode. Error messages, "); Write_Str ("header, summary output to stdout"); Write_Eol; -- Lines for -w switch ! Write_Str (" -wx Warning mode. (x=s/e for supp"); Write_Str ("ress/treat as error)"); Write_Eol; -- Line for -x switch ! Write_Str (" -x Exclude source files (check ob"); Write_Str ("ject consistency only)"); Write_Eol; -- Line for -z switch ! Write_Str (" -z No main subprogram (zero main)"); ! Write_Eol; ! ! -- Line for --RTS ! ! Write_Str (" --RTS=dir specify the default source and object search path"); Write_Eol; -- Line for sfile diff -Nrc3pad gcc-3.2.3/gcc/ada/bindusg.ads gcc-3.3/gcc/ada/bindusg.ads *** gcc-3.2.3/gcc/ada/bindusg.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/bindusg.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/butil.adb gcc-3.3/gcc/ada/butil.adb *** gcc-3.2.3/gcc/ada/butil.adb 2002-05-04 03:27:35.000000000 +0000 --- gcc-3.3/gcc/ada/butil.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/butil.ads gcc-3.3/gcc/ada/butil.ads *** gcc-3.2.3/gcc/ada/butil.ads 2002-05-04 03:27:35.000000000 +0000 --- gcc-3.3/gcc/ada/butil.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/cal.c gcc-3.3/gcc/ada/cal.c *** gcc-3.2.3/gcc/ada/cal.c 2002-05-04 03:27:35.000000000 +0000 --- gcc-3.3/gcc/ada/cal.c 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * C Implementation File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001, Free Software Foundation, Inc. * * * --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/calendar.ads gcc-3.3/gcc/ada/calendar.ads *** gcc-3.2.3/gcc/ada/calendar.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/calendar.ads 2002-03-14 10:59:05.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/casing.adb gcc-3.3/gcc/ada/casing.adb *** gcc-3.2.3/gcc/ada/casing.adb 2002-05-04 03:27:35.000000000 +0000 --- gcc-3.3/gcc/ada/casing.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/casing.ads gcc-3.3/gcc/ada/casing.ads *** gcc-3.2.3/gcc/ada/casing.ads 2002-05-04 03:27:35.000000000 +0000 --- gcc-3.3/gcc/ada/casing.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/ceinfo.adb gcc-3.3/gcc/ada/ceinfo.adb *** gcc-3.2.3/gcc/ada/ceinfo.adb 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/ceinfo.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.12.2 $ -- -- -- Copyright (C) 1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/ChangeLog gcc-3.3/gcc/ada/ChangeLog *** gcc-3.2.3/gcc/ada/ChangeLog 2003-04-22 06:14:27.000000000 +0000 --- gcc-3.3/gcc/ada/ChangeLog 2003-05-14 00:09:16.000000000 +0000 *************** *** 1,18 **** ! 2003-04-22 Release Manager ! * GCC 3.2.3 Released. 2003-03-31 Geert Bosch * link.c : Fix misspelled "const" keyword ! 2003-02-05 Gabriel Dos Reis ! * gnatvsn.ads: Bump version. ! 2003-02-05 Release Manager ! * GCC 3.2.2 Released. 2003-01-29 Joel Sherrill --- 1,64 ---- ! 2003-05-13 Release Manager ! * GCC 3.3 Released. + 2003-05-13 Release Manager + + * GCC 3.3 Released. + + 2003-05-13 Release Manager + + * GCC 3.3 Released. + + 2003-05-13 Release Manager + + * GCC 3.3 Released. + + 2003-04-30 Laurent Guerby + + PR ada/10546 + * 5iosinte.ads: Increase pthread_cond_t size to match recent + LinuxThread and NPTL version. + 2003-03-31 Geert Bosch + PR ada/10020 * link.c : Fix misspelled "const" keyword ! 2003-03-23 Mark Mitchell ! PR c++/7086 ! * utils2.c: Adjust calls to put_var_into_stack. ! 2003-03-05 Olivier Hainque ! PR ada/9961 ! * raise.c : (__gnat_Unwind_RaiseException): Add prototype to avoid ! warning, and fix return type for the IN_RTS && !SJLJ case. ! ! 2003-03-04 Olivier Hainque ! ! PR ada/9911 ! * a-except.adb (Unwind_RaiseException): Import a GNAT specific ! wrapper, which name remains constant whatever underlying GCC ! scheme. ! ! * raise.c (__gnat_Unwind_RaiseException): New wrappers, providing ! the stable interface needed for a-except. ! ! 2003-02-04 Joseph S. Myers ! ! * gnat_rm.texi, gnat_ug.texi: Update to GFDL 1.2. ! * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, ! gnat_ug_wnt.texi: Regenerate. ! ! 2003-01-29 Laurent Guerby ! ! PR ada/8344 ! * final.c: rename to adafinal.c to avoid file name conflicts with ! gcc file. ! * Makefile.in: match previous change. ! * Make-lang.in: match previous change. 2003-01-29 Joel Sherrill *************** *** 25,493 **** is likely needed for all newlib targets. * init.c: Add RTEMS specific version of __gnat_initialize(). ! 2003-01-29 Christian Cornelssen ! * Make-lang.in (gnattools, ada.install-common): ! Complete indentation fixes. ! (ada.install-common): Now really remove the erroneous and ! redundant gnatchop installation commands. ! 2003-01-28 Laurent Guerby ! PR ada/8344 ! * final.c: rename to adafinal.c to avoid file name conflicts with gcc file. ! * Makefile.in: match previous change. ! ! 2003-01-28 Christian Cornelssen ! * Make-lang.in (ada.install-common): Let $(DESTDIR)$(bindir) ! be created if necessary. Remove erroneous and redundant ! gnatchop installation commands. Test for gnatdll before ! attempting to install it. Use initial tab instead of spaces ! in continuation lines. ! (ada.uninstall): Uninstall gnat instead of gnatcmd. ! Also uninstall gnatfind, gnatxref, gnatlbr, and gnatdll ! from all plausible locations. ! * Make-lang.in (ada.install-common, ada.uninstall): ! Prepend $(DESTDIR) to the destination directory in all ! (un)installation commands. ! * Makefile.in (install-gnatlib): Ditto. Rewrite $(LN) ! commands to support DESTDIR with "ln" as well as with ! "ln -s". ! 2002-11-19 Release Manager ! * GCC 3.2.1 Released. ! 2002-11-19 Release Manager ! * GCC 3.2.1 Released. ! 2002-11-18 Release Manager ! * GCC 3.2.1 Released. 2002-08-25 Andre Leis ! David Billinghurst (David.Billinghurst@riotinto.com> ! * sysdep.c (__gnat_ttyname): include on cygwin ! 2002-08-14 Release Manager ! * GCC 3.2 Released. ! 2002-07-25 Release Manager ! * GCC 3.1.1 Released. ! 2002-05-26 Joseph S. Myers ! * gnatvsn.ads (Gnat_Version_String): Change to "3.1.1 20020526 ! (prerelease)". ! 2002-05-14 Release Manager ! * GCC 3.1 Released. ! 2002-05-14 Release Manager ! * GCC 3.1 Released. ! 2002-05-07 Florian Weimer ! * nmake.adt, treeprs.adt: Shorten long Revision: line. ! * xnmake.adb, xtreeprs.adb: Do not write comment trailer for ! Revision: lines. ! 2002-05-05 Florian Weimer ! * 4aintnam.ads, 4cintnam.ads, 4dintnam.ads, 4hintnam.ads, ! 4mintnam.ads, 4nintnam.ads, 4ointnam.ads, 4onumaux.ads, ! 4pintnam.ads, 4rintnam.ads, 4sintnam.ads, 4uintnam.ads, ! 4vcalend.ads, 4vintnam.ads, 4wintnam.ads, 4zintnam.ads, ! 4znumaux.ads, 5avxwork.ads, 5etpopse.adb, 5gintman.adb, ! 5gproinf.ads, 5gtasinf.adb, 5ninmaop.adb, 5nintman.adb, ! 5oparame.adb, 5pvxwork.ads, 5qvxwork.ads, 5rparame.adb, ! 5sintman.adb, 5stasinf.adb, 5stpopse.adb, 5svxwork.ads, ! 5uintman.adb, 5vinmaop.adb, 5vintman.adb, 5vtpopde.adb, ! 5vtpopde.ads, 5wosprim.adb, 6vinterf.ads, 7sinmaop.adb, ! 7sosprim.adb, 7stpopsp.adb, 86numaux.ads, 9drpc.adb, a-astaco.adb, ! a-astaco.ads, a-caldel.ads, a-calend.ads, a-chahan.ads, ! a-charac.ads, a-chlat1.ads, a-colien.adb, a-colien.ads, ! a-decima.adb, a-decima.ads, a-diocst.adb, a-diocst.ads, ! a-direio.adb, a-dynpri.ads, a-excpol.adb, a-filico.ads, ! a-finali.ads, a-flteio.ads, a-fwteio.ads, a-inteio.ads, ! a-interr.adb, a-intnam.ads, a-intsig.adb, a-intsig.ads, ! a-ioexce.ads, a-iwteio.ads, a-lfteio.ads, a-lfwtio.ads, ! a-liteio.ads, a-liwtio.ads, a-llftio.ads, a-llfwti.ads, ! a-llitio.ads, a-lliwti.ads, a-ncelfu.ads, a-ngcoty.ads, ! a-ngelfu.ads, a-nlcefu.ads, a-nlcoty.ads, a-nlelfu.ads, ! a-nllcef.ads, a-nllcty.ads, a-nllefu.ads, a-nscefu.ads, ! a-nscoty.ads, a-nselfu.ads, a-nucoty.ads, a-nuflra.adb, ! a-nuflra.ads, a-numaux.ads, a-numeri.ads, a-sequio.ads, ! a-sfteio.ads, a-sfwtio.ads, a-siocst.adb, a-siocst.ads, ! a-siteio.ads, a-siwtio.ads, a-ssicst.adb, a-ssicst.ads, ! a-ssitio.ads, a-ssiwti.ads, a-storio.adb, a-storio.ads, ! a-stream.ads, a-strfix.ads, a-string.ads, a-strsea.adb, ! a-strsea.ads, a-strunb.ads, a-ststio.ads, a-stunau.adb, ! a-stunau.ads, a-stwibo.ads, a-stwifi.adb, a-stwifi.ads, ! a-stwima.ads, a-stwise.adb, a-stwise.ads, a-sytaco.ads, ! a-tags.ads, a-tasatt.ads, a-teioed.ads, a-ticoau.adb, ! a-ticoau.ads, a-ticoio.adb, a-ticoio.ads, a-tideau.ads, ! a-tideio.ads, a-tienau.ads, a-tifiio.ads, a-tiflau.adb, ! a-tiflau.ads, a-tiflio.ads, a-tiinau.ads, a-tiinio.ads, ! a-timoio.adb, a-tiocst.adb, a-tiocst.ads, a-titest.adb, ! a-titest.ads, a-unccon.ads, a-uncdea.ads, a-wtcoau.adb, ! a-wtcoau.ads, a-wtcoio.adb, a-wtcoio.ads, a-wtcstr.adb, ! a-wtcstr.ads, a-wtdeio.ads, a-wtedit.ads, a-wtenau.ads, ! a-wtfiio.ads, a-wtflau.adb, a-wtflau.ads, a-wtflio.ads, ! a-wtinau.adb, a-wtinau.ads, a-wtinio.ads, a-wtmoau.adb, ! a-wtmoau.ads, a-wtmoio.adb, a-wtmoio.ads, a-wttest.adb, ! a-wttest.ads, ada.ads, binde.ads, bindgen.ads, bindusg.ads, ! calendar.ads, ceinfo.adb, debug_a.adb, debug_a.ads, directio.ads, ! elists.ads, exp_attr.ads, exp_ch10.ads, exp_ch12.ads, ! exp_ch13.ads, exp_ch2.ads, exp_ch6.ads, exp_code.ads, ! exp_disp.ads, exp_dist.ads, exp_fixd.ads, exp_imgv.ads, ! exp_intr.ads, exp_prag.ads, exp_smem.ads, exp_vfpt.adb, ! exp_vfpt.ads, frontend.ads, g-busora.adb, g-busorg.adb, ! g-casuti.adb, g-casuti.ads, g-curexc.ads, g-debuti.adb, ! g-debuti.ads, g-hesora.adb, g-hesorg.adb, g-io_aux.ads, ! g-moreex.adb, g-speche.ads, g-spitbo.adb, g-spitbo.ads, ! g-sptabo.ads, g-sptain.ads, g-sptavs.ads, get_targ.adb, ! gnat1drv.ads, gnatbind.ads, gnatcmd.ads, gnatlink.ads, gnatls.ads, ! gnatmake.adb, gnatmake.ads, gnatprep.ads, gnatpsys.adb, hlo.adb, ! hlo.ads, i-c.ads, i-cexten.ads, i-fortra.adb, i-os2err.ads, ! i-os2lib.ads, i-os2syn.ads, i-os2thr.ads, i-pacdec.ads, ! interfac.ads, ioexcept.ads, itypes.ads, krunch.ads, lib-sort.adb, ! live.ads, machcode.ads, makeusg.ads, math_lib.adb, mdllfile.adb, ! nlists.adb, nlists.ads, par-ch2.adb, par-labl.adb, par.ads, ! prj-com.ads, s-addima.adb, s-addima.ads, s-arit64.ads, ! s-assert.adb, s-assert.ads, s-asthan.adb, s-asthan.ads, ! s-atacco.adb, s-chepoo.ads, s-direio.ads, s-errrep.adb, ! s-errrep.ads, s-exnflt.ads, s-exngen.ads, s-exnint.ads, ! s-exnlfl.ads, s-exnlin.ads, s-exnllf.ads, s-exnlli.ads, ! s-exnsfl.ads, s-exnsin.ads, s-exnssi.ads, s-expflt.ads, ! s-expgen.ads, s-expint.ads, s-explfl.ads, s-explin.ads, ! s-expllf.ads, s-explli.ads, s-expllu.adb, s-expllu.ads, ! s-expmod.adb, s-expmod.ads, s-expsfl.ads, s-expsin.ads, ! s-expssi.ads, s-expuns.adb, s-expuns.ads, s-fatflt.ads, ! s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads, s-finimp.ads, ! s-fore.adb, s-fore.ads, s-gloloc.adb, s-imgbiu.adb, s-imgboo.adb, ! s-imgcha.adb, s-imgint.adb, s-imgllb.adb, s-imglld.adb, ! s-imglli.adb, s-imgllu.adb, s-imgllw.adb, s-imguns.adb, ! s-imgwch.adb, s-imgwiu.adb, s-inmaop.ads, s-io.ads, s-mantis.adb, ! s-mantis.ads, s-pack03.ads, s-pack05.ads, s-pack07.ads, ! s-pack09.ads, s-pack11.ads, s-pack13.ads, s-pack15.ads, ! s-pack17.ads, s-pack19.ads, s-pack21.ads, s-pack23.ads, ! s-pack25.ads, s-pack27.ads, s-pack29.ads, s-pack31.ads, ! s-pack33.ads, s-pack35.ads, s-pack37.ads, s-pack39.ads, ! s-pack41.ads, s-pack43.ads, s-pack45.ads, s-pack47.ads, ! s-pack49.ads, s-pack51.ads, s-pack53.ads, s-pack55.ads, ! s-pack57.ads, s-pack59.ads, s-pack61.ads, s-pack63.ads, ! s-pooglo.ads, s-pooloc.ads, s-poosiz.ads, s-proinf.adb, ! s-proinf.ads, s-rpc.ads, s-sequio.adb, s-sequio.ads, s-shasto.ads, ! s-sopco3.adb, s-sopco4.adb, s-sopco5.adb, s-stoele.adb, ! s-stoele.ads, s-stopoo.ads, s-stratt.adb, s-stratt.ads, ! s-strops.adb, s-taenca.ads, s-tasinf.adb, s-tasren.ads, ! s-tasuti.ads, s-vaflop.ads, s-valboo.adb, s-valboo.ads, ! s-valcha.adb, s-valdec.adb, s-valdec.ads, s-valint.adb, ! s-valint.ads, s-vallld.adb, s-vallld.ads, s-vallli.adb, ! s-vallli.ads, s-valllu.adb, s-valllu.ads, s-valrea.ads, ! s-valuns.adb, s-valuns.ads, s-valuti.ads, s-valwch.adb, ! s-vercon.adb, s-vercon.ads, s-vmexta.ads, s-wchcon.ads, ! s-wchjis.adb, s-wchjis.ads, s-wchstw.ads, s-wchwts.adb, ! s-wchwts.ads, s-widboo.adb, s-widboo.ads, s-widcha.adb, ! s-widcha.ads, s-widlli.adb, s-widlli.ads, s-widllu.adb, ! s-widllu.ads, s-widwch.adb, s-widwch.ads, s-wwdcha.adb, ! s-wwdcha.ads, s-wwdwch.ads, scn-nlit.adb, sdefault.ads, ! sem_aggr.ads, sem_ch10.ads, sem_ch11.ads, sem_ch2.adb, ! sem_ch2.ads, sem_ch4.ads, sem_ch5.ads, sem_ch6.ads, sem_ch7.ads, ! sem_ch8.ads, sem_disp.ads, sem_elim.ads, sem_intr.ads, ! sem_maps.adb, sem_mech.ads, sem_prag.ads, sem_smem.ads, ! sem_vfpt.ads, sequenio.ads, sinput-l.ads, snames.adb, stand.adb, ! switch.ads, text_io.ads, tree_gen.ads, tree_in.ads, tree_io.ads, ! treepr.ads, uname.ads, unchconv.ads, unchdeal.ads, urealp.ads, ! usage.ads, widechar.ads: Adjust Revision: lines which were too ! long. ! 2002-05-03 Joe Buck ! * 1aexcept.adb, 1aexcept.ads, 41intnam.ads, 42intnam.ads, ! 4aintnam.ads, 4cintnam.ads, 4dintnam.ads, 4hexcpol.adb, ! 4lintnam.ads, 4mintnam.ads, 4nintnam.ads, 4onumaux.ads, ! 4pintnam.ads, 4rintnam.ads, 4sintnam.ads, 4uintnam.ads, ! 4vcalend.adb, 4vintnam.ads, 4wcalend.adb, 4wexcpol.adb, ! 4wintnam.ads, 4zintnam.ads, 4znumaux.ads, 4zsytaco.adb, ! 4zsytaco.ads, 51osinte.adb, 51osinte.ads, 52osinte.adb, ! 52osinte.ads, 52system.ads, 53osinte.ads, 5aosinte.ads, ! 5asystem.ads, 5atasinf.ads, 5ataspri.ads, 5avxwork.ads, ! 5bosinte.ads, 5bsystem.ads, 5cosinte.ads, 5dosinte.ads, ! 5esystem.ads, 5fosinte.ads, 5fsystem.ads, 5ftasinf.ads, ! 5ginterr.adb, 5gmastop.adb, 5gosinte.ads, 5gproinf.adb, ! 5gproinf.ads, 5gsystem.ads, 5gtasinf.adb, 5gtasinf.ads, ! 5gtpgetc.adb, 5hparame.ads, 5hsystem.ads, 5htaspri.ads, ! 5iosinte.ads, 5itaspri.ads, 5ksystem.ads, 5kvxwork.ads, ! 5losinte.ads, 5lsystem.ads, 5mosinte.ads, 5mvxwork.ads, ! 5ninmaop.adb, 5nintman.adb, 5nosinte.ads, 5ntaspri.ads, ! 5oosprim.adb, 5oparame.adb, 5osystem.ads, 5posinte.ads, ! 5posprim.adb, 5pvxwork.ads, 5qparame.ads, 5qvxwork.ads, ! 5rosinte.ads, 5rparame.adb, 5sintman.adb, 5sosinte.ads, ! 5sparame.adb, 5ssystem.ads, 5stasinf.adb, 5stasinf.ads, ! 5staspri.ads, 5svxwork.ads, 5tosinte.ads, 5uosinte.ads, ! 5vasthan.adb, 5vinterr.adb, 5vintman.ads, 5vosinte.ads, ! 5vosprim.adb, 5vosprim.ads, 5vparame.ads, 5vsystem.ads, ! 5vtaspri.ads, 5vtpopde.adb, 5vtpopde.ads, 5vvaflop.adb, ! 5wintman.adb, 5wmemory.adb, 5wosinte.ads, 5wosprim.adb, ! 5wsystem.ads, 5wtaprop.adb, 5wtaspri.ads, 5ysystem.ads, ! 5zinterr.adb, 5zosinte.adb, 5zosinte.ads, 5zosprim.adb, ! 5zparame.ads, 5zsystem.ads, 6vcpp.adb, 6vcstrea.adb, ! 7sosprim.adb, 86numaux.adb, 86numaux.ads, 9drpc.adb, ! a-astaco.adb, a-caldel.ads, a-calend.adb, a-calend.ads, ! a-chahan.adb, a-chahan.ads, a-colien.adb, a-colien.ads, ! a-colire.adb, a-colire.ads, a-comlin.adb, a-comlin.ads, ! a-cwila1.ads, a-decima.adb, a-decima.ads, a-diocst.adb, ! a-diocst.ads, a-direio.adb, a-direio.ads, a-einuoc.adb, ! a-einuoc.ads, a-except.adb, a-except.ads, a-excpol.adb, ! a-exctra.adb, a-exctra.ads, a-filico.adb, a-filico.ads, ! a-finali.adb, a-finali.ads, a-interr.ads, a-intsig.adb, ! a-intsig.ads, a-ngcefu.adb, a-ngcoty.adb, a-ngcoty.ads, ! a-ngelfu.adb, a-nudira.adb, a-nudira.ads, a-nuflra.adb, ! a-nuflra.ads, a-numaux.ads, a-reatim.ads, a-retide.ads, ! a-sequio.adb, a-sequio.ads, a-siocst.adb, a-siocst.ads, ! a-ssicst.adb, a-ssicst.ads, a-stmaco.ads, a-storio.adb, ! a-strbou.adb, a-strbou.ads, a-stream.ads, a-strfix.adb, ! a-strfix.ads, a-strmap.adb, a-strmap.ads, a-strsea.adb, ! a-strsea.ads, a-strunb.adb, a-strunb.ads, a-ststio.adb, ! a-ststio.ads, a-stunau.adb, a-stunau.ads, a-stwibo.adb, ! a-stwibo.ads, a-stwifi.adb, a-stwima.adb, a-stwima.ads, ! a-stwise.adb, a-stwise.ads, a-stwiun.adb, a-stwiun.ads, ! a-suteio.adb, a-suteio.ads, a-swmwco.ads, a-swuwti.adb, ! a-swuwti.ads, a-sytaco.adb, a-sytaco.ads, a-tags.adb, ! a-tags.ads, a-tasatt.ads, a-taside.adb, a-taside.ads, ! a-teioed.adb, a-teioed.ads, a-textio.adb, a-textio.ads, ! a-ticoau.adb, a-ticoau.ads, a-ticoio.adb, a-ticoio.ads, ! a-tideau.adb, a-tideau.ads, a-tideio.adb, a-tideio.ads, ! a-tienau.adb, a-tienau.ads, a-tienio.adb, a-tienio.ads, ! a-tifiio.adb, a-tifiio.ads, a-tiflau.adb, a-tiflau.ads, ! a-tiflio.adb, a-tiflio.ads, a-tigeau.adb, a-tigeau.ads, ! a-tiinau.adb, a-tiinau.ads, a-tiinio.adb, a-tiinio.ads, ! a-timoau.adb, a-timoau.ads, a-timoio.adb, a-timoio.ads, ! a-tiocst.adb, a-tiocst.ads, a-titest.adb, a-witeio.adb, ! a-witeio.ads, a-wtcoau.adb, a-wtcoau.ads, a-wtcoio.adb, ! a-wtcstr.adb, a-wtcstr.ads, a-wtdeau.adb, a-wtdeau.ads, ! a-wtdeio.adb, a-wtdeio.ads, a-wtedit.adb, a-wtedit.ads, ! a-wtenau.adb, a-wtenau.ads, a-wtenio.adb, a-wtenio.ads, ! a-wtfiio.adb, a-wtfiio.ads, a-wtflau.adb, a-wtflau.ads, ! a-wtflio.adb, a-wtflio.ads, a-wtgeau.adb, a-wtgeau.ads, ! a-wtinau.adb, a-wtinau.ads, a-wtinio.adb, a-wtmoau.adb, ! a-wtmoau.ads, a-wtmoio.adb, a-wtmoio.ads, a-wttest.adb, ! ada-tree.def, ada-tree.h, ada.h, adaint.c, adaint.h, ! ali-util.adb, ali-util.ads, ali.adb, ali.ads, alloc.ads, ! argv.c, atree.adb, atree.ads, atree.h, back_end.adb, ! back_end.ads, bcheck.adb, bcheck.ads, binde.adb, binde.ads, ! binderr.adb, binderr.ads, bindgen.adb, bindgen.ads, ! bindusg.adb, bindusg.ads, butil.adb, butil.ads, cal.c, ! casing.adb, casing.ads, ceinfo.adb, checks.adb, checks.ads, ! cio.c, comperr.adb, comperr.ads, csets.adb, csets.ads, ! csinfo.adb, cstand.adb, cstand.ads, cstreams.c, cuintp.c, ! debug.adb, debug.ads, debug_a.adb, debug_a.ads, dec-io.adb, ! dec-io.ads, dec.ads, decl.c, deftarg.c, einfo.adb, einfo.ads, ! einfo.h, elists.adb, elists.ads, elists.h, errno.c, errout.adb, ! errout.ads, eval_fat.adb, eval_fat.ads, exit.c, exp_aggr.adb, ! exp_aggr.ads, exp_attr.adb, exp_attr.ads, exp_ch10.ads, ! exp_ch11.adb, exp_ch11.ads, exp_ch12.adb, exp_ch12.ads, ! exp_ch13.adb, exp_ch13.ads, exp_ch2.adb, exp_ch2.ads, ! exp_ch3.adb, exp_ch3.ads, exp_ch4.adb, exp_ch4.ads, ! exp_ch5.adb, exp_ch5.ads, exp_ch6.adb, exp_ch6.ads, ! exp_ch7.adb, exp_ch7.ads, exp_ch8.adb, exp_ch8.ads, ! exp_ch9.adb, exp_ch9.ads, exp_code.adb, exp_code.ads, ! exp_dbug.adb, exp_dbug.ads, exp_disp.adb, exp_disp.ads, ! exp_dist.adb, exp_dist.ads, exp_fixd.adb, exp_fixd.ads, ! exp_imgv.adb, exp_imgv.ads, exp_intr.adb, exp_intr.ads, ! exp_pakd.adb, exp_pakd.ads, exp_prag.adb, exp_prag.ads, ! exp_smem.adb, exp_smem.ads, exp_strm.adb, exp_strm.ads, ! exp_tss.adb, exp_tss.ads, exp_util.adb, exp_util.ads, ! exp_vfpt.adb, exp_vfpt.ads, expander.adb, expander.ads, fe.h, ! final.c, fmap.adb, fmap.ads, fname-sf.adb, fname-sf.ads, ! fname-uf.adb, fname-uf.ads, fname.adb, fname.ads, freeze.adb, ! freeze.ads, frontend.adb, frontend.ads, g-calend.ads, ! g-comlin.adb, g-debpoo.adb, g-debpoo.ads, g-locfil.adb, ! g-os_lib.ads, g-regist.adb, g-regist.ads, get_targ.adb, ! get_targ.ads, gigi.h, gmem.c, gnat1drv.adb, gnat1drv.ads, ! gnat_ug.texi, gnatbind.adb, gnatbind.ads, gnatbl.c, ! gnatcmd.adb, gnatcmd.ads, gnatdll.adb, gnatfind.adb, ! gnatkr.adb, gnatkr.ads, gnatlbr.adb, gnatlink.adb, ! gnatlink.ads, gnatls.adb, gnatls.ads, gnatmain.adb, ! gnatmain.ads, gnatmake.adb, gnatmake.ads, gnatmem.adb, ! gnatprep.adb, gnatprep.ads, gnatpsta.adb, gnatpsys.adb, ! gnatvsn.ads, gnatxref.adb, hlo.adb, hlo.ads, hostparm.ads, ! i-c.adb, i-cexten.ads, i-cobol.adb, i-cobol.ads, i-cpoint.adb, ! i-cpoint.ads, i-cpp.adb, i-cpp.ads, i-cstrea.adb, i-cstrea.ads, ! i-cstrin.adb, i-cstrin.ads, i-fortra.adb, i-os2err.ads, ! i-os2lib.adb, i-os2lib.ads, i-os2syn.ads, i-os2thr.ads, ! i-pacdec.adb, i-pacdec.ads, impunit.adb, impunit.ads, init.c, ! inline.adb, inline.ads, io-aux.c, itypes.adb, itypes.ads, ! krunch.adb, krunch.ads, lang-options.h, lang-specs.h, ! layout.adb, layout.ads, lib-list.adb, lib-load.adb, ! lib-load.ads, lib-sort.adb, lib-util.adb, lib-util.ads, ! lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads, ! lib.adb, lib.ads, link.c, live.adb, live.ads, make.adb, ! make.ads, makeusg.adb, makeusg.ads, math_lib.adb, mdll.adb, ! mdll.ads, mdllfile.adb, mdllfile.ads, mdlltool.adb, ! mdlltool.ads, memtrack.adb, misc.c, namet.adb, namet.ads, ! namet.h, nlists.adb, nlists.ads, nlists.h, nmake.adb, ! nmake.ads, nmake.adt, opt.adb, opt.ads, osint.adb, osint.ads, ! output.adb, output.ads, par-ch10.adb, par-ch11.adb, ! par-ch12.adb, par-ch13.adb, par-ch2.adb, par-ch3.adb, ! par-ch4.adb, par-ch5.adb, par-ch6.adb, par-ch7.adb, ! par-ch8.adb, par-ch9.adb, par-endh.adb, par-labl.adb, ! par-load.adb, par-prag.adb, par-sync.adb, par-tchk.adb, ! par-util.adb, par.adb, par.ads, prj-attr.adb, prj-attr.ads, ! prj-com.adb, prj-com.ads, prj-dect.adb, prj-dect.ads, ! prj-env.adb, prj-env.ads, prj-ext.adb, prj-ext.ads, ! prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, prj-pars.ads, ! prj-part.adb, prj-part.ads, prj-proc.adb, prj-proc.ads, ! prj-strt.adb, prj-strt.ads, prj-tree.adb, prj-tree.ads, ! prj-util.adb, prj-util.ads, prj.adb, prj.ads, raise.c, raise.h, ! repinfo.adb, repinfo.ads, repinfo.h, restrict.adb, ! restrict.ads, rident.ads, rtsfind.adb, rtsfind.ads, ! s-addima.adb, s-addima.ads, s-arit64.adb, s-arit64.ads, ! s-assert.adb, s-assert.ads, s-asthan.adb, s-asthan.ads, ! s-atacco.adb, s-auxdec.adb, s-auxdec.ads, s-bitops.adb, ! s-bitops.ads, s-chepoo.ads, s-direio.adb, s-direio.ads, ! s-except.ads, s-exctab.adb, s-exctab.ads, s-exnflt.ads, ! s-exngen.adb, s-exngen.ads, s-exnint.ads, s-exnlfl.ads, ! s-exnlin.ads, s-exnllf.ads, s-exnlli.ads, s-exnsfl.ads, ! s-exnsin.ads, s-exnssi.ads, s-expflt.ads, s-expgen.adb, ! s-expgen.ads, s-expint.ads, s-explfl.ads, s-explin.ads, ! s-expllf.ads, s-explli.ads, s-expllu.adb, s-expllu.ads, ! s-expmod.adb, s-expmod.ads, s-expsfl.ads, s-expsin.ads, ! s-expssi.ads, s-expuns.adb, s-expuns.ads, s-fatflt.ads, ! s-fatgen.adb, s-fatgen.ads, s-fatlfl.ads, s-fatllf.ads, ! s-fatsfl.ads, s-ficobl.ads, s-fileio.adb, s-fileio.ads, ! s-finimp.adb, s-finimp.ads, s-finroo.adb, s-finroo.ads, ! s-fore.adb, s-fore.ads, s-imgbiu.adb, s-imgbiu.ads, ! s-imgboo.adb, s-imgboo.ads, s-imgcha.adb, s-imgcha.ads, ! s-imgdec.adb, s-imgdec.ads, s-imgenu.adb, s-imgenu.ads, ! s-imgint.adb, s-imgint.ads, s-imgllb.adb, s-imgllb.ads, ! s-imglld.adb, s-imglld.ads, s-imglli.adb, s-imglli.ads, ! s-imgllu.adb, s-imgllu.ads, s-imgllw.adb, s-imgllw.ads, ! s-imgrea.adb, s-imgrea.ads, s-imguns.adb, s-imguns.ads, ! s-imgwch.adb, s-imgwch.ads, s-imgwiu.adb, s-imgwiu.ads, ! s-inmaop.ads, s-interr.adb, s-interr.ads, s-intman.ads, ! s-io.adb, s-io.ads, s-maccod.ads, s-mantis.adb, s-mantis.ads, ! s-memory.adb, s-memory.ads, s-osprim.ads, s-pack03.adb, ! s-pack03.ads, s-pack05.adb, s-pack05.ads, s-pack06.adb, ! s-pack06.ads, s-pack07.adb, s-pack07.ads, s-pack09.adb, ! s-pack09.ads, s-pack10.adb, s-pack10.ads, s-pack11.adb, ! s-pack11.ads, s-pack12.adb, s-pack12.ads, s-pack13.adb, ! s-pack13.ads, s-pack14.adb, s-pack14.ads, s-pack15.adb, ! s-pack15.ads, s-pack17.adb, s-pack17.ads, s-pack18.adb, ! s-pack18.ads, s-pack19.adb, s-pack19.ads, s-pack20.adb, ! s-pack20.ads, s-pack21.adb, s-pack21.ads, s-pack22.adb, ! s-pack22.ads, s-pack23.adb, s-pack23.ads, s-pack24.adb, ! s-pack24.ads, s-pack25.adb, s-pack25.ads, s-pack26.adb, ! s-pack26.ads, s-pack27.adb, s-pack27.ads, s-pack28.adb, ! s-pack28.ads, s-pack29.adb, s-pack29.ads, s-pack30.adb, ! s-pack30.ads, s-pack31.adb, s-pack31.ads, s-pack33.adb, ! s-pack33.ads, s-pack34.adb, s-pack34.ads, s-pack35.adb, ! s-pack35.ads, s-pack36.adb, s-pack36.ads, s-pack37.adb, ! s-pack37.ads, s-pack38.adb, s-pack38.ads, s-pack39.adb, ! s-pack39.ads, s-pack40.adb, s-pack40.ads, s-pack41.adb, ! s-pack41.ads, s-pack42.adb, s-pack42.ads, s-pack43.adb, ! s-pack43.ads, s-pack44.adb, s-pack44.ads, s-pack45.adb, ! s-pack45.ads, s-pack46.adb, s-pack46.ads, s-pack47.adb, ! s-pack47.ads, s-pack48.adb, s-pack48.ads, s-pack49.adb, ! s-pack49.ads, s-pack50.adb, s-pack50.ads, s-pack51.adb, ! s-pack51.ads, s-pack52.adb, s-pack52.ads, s-pack53.adb, ! s-pack53.ads, s-pack54.adb, s-pack54.ads, s-pack55.adb, ! s-pack55.ads, s-pack56.adb, s-pack56.ads, s-pack57.adb, ! s-pack57.ads, s-pack58.adb, s-pack58.ads, s-pack59.adb, ! s-pack59.ads, s-pack60.adb, s-pack60.ads, s-pack61.adb, ! s-pack61.ads, s-pack62.adb, s-pack62.ads, s-pack63.adb, ! s-pack63.ads, s-parame.adb, s-parame.ads, s-parint.adb, ! s-parint.ads, s-pooglo.adb, s-pooglo.ads, s-pooloc.adb, ! s-pooloc.ads, s-poosiz.adb, s-poosiz.ads, s-powtab.ads, ! s-proinf.adb, s-proinf.ads, s-rpc.adb, s-rpc.ads, s-scaval.ads, ! s-secsta.adb, s-secsta.ads, s-sequio.adb, s-sequio.ads, ! s-shasto.adb, s-shasto.ads, s-soflin.adb, s-soflin.ads, ! s-sopco3.adb, s-sopco3.ads, s-sopco4.adb, s-sopco4.ads, ! s-sopco5.adb, s-sopco5.ads, s-stache.adb, s-stache.ads, ! s-stalib.adb, s-stalib.ads, s-stoele.adb, s-stopoo.ads, ! s-stratt.adb, s-stratt.ads, s-strops.adb, s-strops.ads, ! s-taprob.ads, s-taprop.ads, s-tarest.ads, s-tasdeb.adb, ! s-tasdeb.ads, s-tasinf.adb, s-tasinf.ads, s-tasini.ads, ! s-taskin.ads, s-tasren.ads, s-tasres.ads, s-tassta.ads, ! s-tpinop.adb, s-tpinop.ads, s-tpoben.ads, s-tpobop.ads, ! s-unstyp.ads, s-vaflop.adb, s-vaflop.ads, s-valboo.adb, ! s-valboo.ads, s-valcha.adb, s-valcha.ads, s-valdec.adb, ! s-valdec.ads, s-valenu.adb, s-valenu.ads, s-valint.adb, ! s-valint.ads, s-vallld.adb, s-vallld.ads, s-vallli.adb, ! s-vallli.ads, s-valllu.adb, s-valllu.ads, s-valrea.adb, ! s-valrea.ads, s-valuns.adb, s-valuns.ads, s-valuti.adb, ! s-valuti.ads, s-valwch.adb, s-valwch.ads, s-vercon.adb, ! s-vercon.ads, s-vmexta.adb, s-vmexta.ads, s-wchcnv.adb, ! s-wchcnv.ads, s-wchcon.ads, s-wchjis.adb, s-wchjis.ads, ! s-wchstw.adb, s-wchstw.ads, s-wchwts.adb, s-wchwts.ads, ! s-widboo.adb, s-widboo.ads, s-widcha.adb, s-widcha.ads, ! s-widenu.adb, s-widenu.ads, s-widlli.adb, s-widlli.ads, ! s-widllu.adb, s-widllu.ads, s-widwch.adb, s-widwch.ads, ! s-wwdcha.adb, s-wwdcha.ads, s-wwdenu.adb, s-wwdenu.ads, ! s-wwdwch.adb, s-wwdwch.ads, scans.adb, scans.ads, scn-nlit.adb, ! scn-slit.adb, scn.adb, scn.ads, sdefault.ads, sem.adb, sem.ads, ! sem_aggr.adb, sem_aggr.ads, sem_attr.adb, sem_attr.ads, ! sem_case.adb, sem_case.ads, sem_cat.adb, sem_cat.ads, ! sem_ch10.adb, sem_ch10.ads, sem_ch11.adb, sem_ch11.ads, ! sem_ch12.adb, sem_ch12.ads, sem_ch13.adb, sem_ch13.ads, ! sem_ch2.adb, sem_ch2.ads, sem_ch3.adb, sem_ch3.ads, ! sem_ch4.adb, sem_ch4.ads, sem_ch5.adb, sem_ch5.ads, ! sem_ch6.adb, sem_ch6.ads, sem_ch7.adb, sem_ch7.ads, ! sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, sem_ch9.ads, ! sem_disp.adb, sem_disp.ads, sem_dist.adb, sem_dist.ads, ! sem_elab.adb, sem_elab.ads, sem_elim.adb, sem_elim.ads, ! sem_eval.adb, sem_eval.ads, sem_intr.adb, sem_intr.ads, ! sem_maps.adb, sem_maps.ads, sem_mech.adb, sem_mech.ads, ! sem_prag.adb, sem_prag.ads, sem_res.adb, sem_res.ads, ! sem_smem.adb, sem_smem.ads, sem_type.adb, sem_type.ads, ! sem_util.adb, sem_util.ads, sem_vfpt.adb, sem_vfpt.ads, ! sem_warn.adb, sem_warn.ads, sfn_scan.adb, sfn_scan.ads, ! sinfo-cn.adb, sinfo-cn.ads, sinfo.adb, sinfo.ads, sinfo.h, ! sinput-l.adb, sinput-l.ads, sinput-p.adb, sinput-p.ads, ! sinput.adb, sinput.ads, snames.adb, snames.ads, snames.h, ! sprint.adb, sprint.ads, stand.adb, stand.ads, stringt.adb, ! stringt.ads, stringt.h, style.adb, style.ads, stylesw.adb, ! stylesw.ads, switch.adb, switch.ads, sysdep.c, system.ads, ! table.adb, table.ads, targparm.adb, targparm.ads, targtyps.c, ! tbuild.adb, tbuild.ads, trans.c, tree_gen.adb, tree_gen.ads, ! tree_in.adb, tree_in.ads, tree_io.adb, tree_io.ads, treepr.adb, ! treepr.ads, treeprs.ads, treeprs.adt, ttypef.ads, ttypes.ads, ! types.adb, types.ads, types.h, uintp.adb, uintp.ads, uintp.h, ! uname.adb, uname.ads, urealp.adb, urealp.ads, urealp.h, ! usage.adb, usage.ads, utils.c, utils2.c, validsw.adb, ! validsw.ads, widechar.adb, widechar.ads, xeinfo.adb, ! xnmake.adb, xr_tabls.adb, xr_tabls.ads, xref_lib.adb, ! xref_lib.ads, xsinfo.adb, xsnames.adb, xtreeprs.adb : Change ! Ada Core Technologies from maintainer to contributor. ! 2002-05-02 John David Anglin ! * Makefile.in (ALL_ADAFLAGS, MOST_ADAFLAGS): Add CFLAGS to defines. ! 2002-05-01 Geert Bosch ! * comperr.adb : Fix typo. ! 2002-05-01 Geert Bosch ! * bindgen.adb (Public_Version_Warning): Remove. ! * gnatvsn.ads : Change to match GCC 3.1 version. ! * comperr.adb : Change bug box, remove ACT-specific circuitry. ! * comperr.ads : Update comments to reflect changed bug message. 2002-04-21 Joseph S. Myers --- 71,695 ---- is likely needed for all newlib targets. * init.c: Add RTEMS specific version of __gnat_initialize(). ! 2003-01-28 Christian Cornelssen ! * Make-lang.in (ada.install-info): Let $(DESTDIR)$(infodir) ! be created if necessary. ! (ada.install-common): Let $(DESTDIR)$(bindir) be created ! if necessary. Remove erroneous and redundant gnatchop ! installation commands. Test for gnatdll before attempting ! to install it. ! (ada.uninstall): Also uninstall gnatfind, gnatxref, gnatlbr, ! and gnatdll from all plausible locations. ! (cross-gnattools, ada.install-common): Use initial tab ! instead of spaces in continuation lines. ! 2003-01-26 Christian Cornelssen ! * Make-lang.in (ada.install-info, ada.install-common) ! (ada.uninstall): Prepend $(DESTDIR) to the destination ! directory in all (un)installation commands. ! * Makefile.in (install-gnatlib, install-rts): Ditto. ! 2002-12-28 Joseph S. Myers ! * gnat_rm.texi, gnat_ug.texi: Use @copying. ! * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, ! gnat_ug_wnt.texi: Regenerate. ! 2002-12-23 Joseph S. Myers ! * gnat_rm.texi: Include gcc-common.texi. Use GCC version number ! only. ! * Make-lang.in ($(srcdir)/ada/gnat_ug_unx.info, ! $(srcdir)/ada/gnat_ug_vms.info, $(srcdir)/ada/gnat_ug_vxw.info, ! $(srcdir)/ada/gnat_ug_wnt.info, $(srcdir)/ada/gnat_rm.info, ! ada/gnat_ug_unx.dvi, ada/gnat_ug_vms.dvi, ada/gnat_ug_vxw.dvi, ! ada/gnat_ug_wnt.dvi, ada/gnat_rm.dvi): Depend on ! $(srcdir)/doc/include/gcc-common.texi. ! 2002-11-18 Nathanael Nerode ! * adaint.c (__gnat_tmp_name): Better, but good enough for now, ! solution to buffer overflow bug on GNU/Linux. ! 2002-11-14 Nathanael Nerode ! Closes PR ada/5856 and PR ada/6919 ! ! * bindgen.adb: Remove all references to Public_Version. ! * comperr.adb: Remove all references to Public_Version and ! GNATPRO_Version; correct bug reporting instructions. ! * comperr.ads: Change to match bug box. ! * gnatvsn.ads: Remove all references to Public version and ! GNATPRO version. ! 2002-11-13 Nathanael Nerode ! PR ada/6919 ! * adaint.c (__gnat_tmp_name): Remove buffer overflow bug on ! GNU/Linux. ! PR ada/6558 ! * config-lang.in: Remove diff_excludes. ! ! 2002-11-05 Graham Stott ! PR ada/8358 ! * trans.c (gnu_pending_elaboration_lists): New GC root. ! (build_unit_elab): Use.. ! ! 2002-10-30 Geert Bosch ! PR ada/6558 ! * misc.c : Include optabs.h ! ! * Make-lang.in (misc.o): Add dependency on optabs.h ! ! 2002-10-29 Geert Bosch ! PR ada/6558 ! * Make-lang.in (gnatbind): Depend on CONFIG_H ! ! 2002-10-29 Geert bosch ! PR ada/6558 ! * misc.c: Unrevert misc.c (1.13) ! ! 2002-10-28 Nathanael Nerode ! ! * a-chlat9.ads a-cwila9.ads a-dynpri.adb a-retide.adb: Update ! maintainership comments. ! ! 2002-09-25 Nathanael Nerode ! PR ada/5904 ! * 5ataprop.adb 5atpopsp.adb 5bosinte.adb 5ftaprop.adb ! 5gtaprop.adb 5htaprop.adb 5rosinte.ads 5staprop.adb ! 5stpopse.adb 5vtaspri.ads 5zintman.adb 5ztaprop.adb ! 7staprop.adb: Correct statements in comments about ! maintainership of GNAT. ! ! PR ada/5904 ! * 1ssecsta.adb 1ssecsta.ads adadecode.c adadecode.h aux-io.c ! gnatname.adb gnatname.ads mkdir.c osint-b.adb osint-b.ads ! osint-c.adb osint-c.ads osint-l.adb osint-l.ads osint-m.adb ! osint-m.ads prj-makr.adb prj-makr.ads prj-pp.adb prj-pp.ads ! s-atacco.ads s-traceb.adb s-traceb.ads s-traces.adb ! s-traces.ads s-tratas.adb s-tratas.ads sinput-d.adb ! sinput-d.ads switch-b.adb switch-b.ads switch-c.adb ! switch-c.ads switch-m.adb switch-m.ads: Correct statements in ! comments about maintainership of GNAT. ! ! PR ada/6919 (forward port of patch for PR ada/5904) ! * 1aexcept.adb 1aexcept.ads 41intnam.ads 42intnam.ads ! 4aintnam.ads 4cintnam.ads 4dintnam.ads 4hexcpol.adb ! 4lintnam.ads 4mintnam.ads 4nintnam.ads 4onumaux.ads ! 4pintnam.ads 4rintnam.ads 4sintnam.ads 4uintnam.ads ! 4vcalend.adb 4vintnam.ads 4wcalend.adb 4wexcpol.adb ! 4wintnam.ads 4zintnam.ads 4znumaux.ads 4zsytaco.adb ! 4zsytaco.ads 51osinte.adb 51osinte.ads 52osinte.adb ! 52osinte.ads 52system.ads 53osinte.ads 5aosinte.ads ! 5asystem.ads 5atasinf.ads 5ataspri.ads 5avxwork.ads ! 5bosinte.ads 5bsystem.ads 5cosinte.ads 5dosinte.ads ! 5esystem.ads 5fosinte.ads 5fsystem.ads 5ftasinf.ads ! 5ginterr.adb 5gmastop.adb 5gosinte.ads 5gproinf.adb ! 5gproinf.ads 5gsystem.ads 5gtasinf.adb 5gtasinf.ads ! 5gtpgetc.adb 5hparame.ads 5hsystem.ads 5htaspri.ads ! 5iosinte.ads 5itaspri.ads 5ksystem.ads 5kvxwork.ads ! 5losinte.ads 5lsystem.ads 5mosinte.ads 5mvxwork.ads ! 5ninmaop.adb 5nintman.adb 5nosinte.ads 5ntaspri.ads ! 5oosprim.adb 5oparame.adb 5osystem.ads 5posinte.ads ! 5posprim.adb 5pvxwork.ads 5rosinte.ads 5rparame.adb ! 5sintman.adb 5sosinte.ads 5sparame.adb 5ssystem.ads ! 5stasinf.adb 5stasinf.ads 5staspri.ads 5svxwork.ads ! 5tosinte.ads 5uosinte.ads 5vasthan.adb 5vinterr.adb ! 5vintman.ads 5vosinte.ads 5vosprim.adb 5vosprim.ads ! 5vparame.ads 5vsystem.ads 5vtaspri.ads 5vtpopde.adb ! 5vtpopde.ads 5vvaflop.adb 5wintman.adb 5wmemory.adb ! 5wosinte.ads 5wosprim.adb 5wsystem.ads 5wtaprop.adb ! 5wtaspri.ads 5ysystem.ads 5zinterr.adb 5zosinte.adb ! 5zosinte.ads 5zosprim.adb 5zsystem.ads 6vcpp.adb 6vcstrea.adb ! 7sosprim.adb 86numaux.adb 86numaux.ads 9drpc.adb a-astaco.adb ! a-caldel.ads a-calend.adb a-calend.ads a-chahan.adb ! a-chahan.ads a-colien.adb a-colien.ads a-colire.adb ! a-colire.ads a-comlin.adb a-comlin.ads a-cwila1.ads ! a-decima.adb a-decima.ads a-diocst.adb a-diocst.ads ! a-direio.adb a-direio.ads a-einuoc.adb a-einuoc.ads ! a-except.adb a-except.ads a-excpol.adb a-exctra.adb ! a-exctra.ads a-filico.adb a-filico.ads a-finali.adb ! a-finali.ads a-interr.ads a-intsig.adb a-intsig.ads ! a-ngcefu.adb a-ngcoty.adb a-ngcoty.ads a-ngelfu.adb ! a-nudira.adb a-nudira.ads a-nuflra.adb a-nuflra.ads ! a-numaux.ads a-reatim.ads a-retide.ads a-sequio.adb ! a-sequio.ads a-siocst.adb a-siocst.ads a-ssicst.adb ! a-ssicst.ads a-stmaco.ads a-storio.adb a-strbou.adb ! a-strbou.ads a-stream.ads a-strfix.adb a-strfix.ads ! a-strmap.adb a-strmap.ads a-strsea.adb a-strsea.ads ! a-strunb.adb a-strunb.ads a-ststio.adb a-ststio.ads ! a-stunau.adb a-stunau.ads a-stwibo.adb a-stwibo.ads ! a-stwifi.adb a-stwima.adb a-stwima.ads a-stwise.adb ! a-stwise.ads a-stwiun.adb a-stwiun.ads a-suteio.adb ! a-suteio.ads a-swmwco.ads a-swuwti.adb a-swuwti.ads ! a-sytaco.adb a-sytaco.ads a-tags.adb a-tags.ads a-tasatt.ads ! a-taside.adb a-taside.ads a-teioed.adb a-teioed.ads ! a-textio.adb a-textio.ads a-ticoau.adb a-ticoau.ads ! a-ticoio.adb a-ticoio.ads a-tideau.adb a-tideau.ads ! a-tideio.adb a-tideio.ads a-tienau.adb a-tienau.ads ! a-tienio.adb a-tienio.ads a-tifiio.adb a-tifiio.ads ! a-tiflau.adb a-tiflau.ads a-tiflio.adb a-tiflio.ads ! a-tigeau.adb a-tigeau.ads a-tiinau.adb a-tiinau.ads ! a-tiinio.adb a-tiinio.ads a-timoau.adb a-timoau.ads ! a-timoio.adb a-timoio.ads a-tiocst.adb a-tiocst.ads ! a-titest.adb a-witeio.adb a-witeio.ads a-wtcoau.adb ! a-wtcoau.ads a-wtcoio.adb a-wtcstr.adb a-wtcstr.ads ! a-wtdeau.adb a-wtdeau.ads a-wtdeio.adb a-wtdeio.ads ! a-wtedit.adb a-wtedit.ads a-wtenau.adb a-wtenau.ads ! a-wtenio.adb a-wtenio.ads a-wtfiio.adb a-wtfiio.ads ! a-wtflau.adb a-wtflau.ads a-wtflio.adb a-wtflio.ads ! a-wtgeau.adb a-wtgeau.ads a-wtinau.adb a-wtinau.ads ! a-wtinio.adb a-wtmoau.adb a-wtmoau.ads a-wtmoio.adb ! a-wtmoio.ads a-wttest.adb ada-tree.def ada-tree.h ada.h ! adaint.c adaint.h ali-util.adb ali-util.ads ali.adb ali.ads ! alloc.ads argv.c atree.adb atree.ads atree.h back_end.adb ! back_end.ads bcheck.adb bcheck.ads binde.adb binde.ads ! binderr.adb binderr.ads bindgen.adb bindgen.ads bindusg.adb ! bindusg.ads butil.adb butil.ads cal.c casing.adb casing.ads ! ceinfo.adb checks.adb checks.ads cio.c comperr.adb comperr.ads ! csets.adb csets.ads csinfo.adb cstand.adb cstand.ads ! cstreams.c cuintp.c debug.adb debug.ads debug_a.adb ! debug_a.ads dec-io.adb dec-io.ads dec.ads decl.c deftarg.c ! einfo.adb einfo.ads einfo.h elists.adb elists.ads elists.h ! errno.c errout.adb errout.ads eval_fat.adb eval_fat.ads exit.c ! exp_aggr.adb exp_aggr.ads exp_attr.adb exp_attr.ads ! exp_ch10.ads exp_ch11.adb exp_ch11.ads exp_ch12.adb ! exp_ch12.ads exp_ch13.adb exp_ch13.ads exp_ch2.adb exp_ch2.ads ! exp_ch3.adb exp_ch3.ads exp_ch4.adb exp_ch4.ads exp_ch5.adb ! exp_ch5.ads exp_ch6.adb exp_ch6.ads exp_ch7.adb exp_ch7.ads ! exp_ch8.adb exp_ch8.ads exp_ch9.adb exp_ch9.ads exp_code.adb ! exp_code.ads exp_dbug.adb exp_dbug.ads exp_disp.adb ! exp_disp.ads exp_dist.adb exp_dist.ads exp_fixd.adb ! exp_fixd.ads exp_imgv.adb exp_imgv.ads exp_intr.adb ! exp_intr.ads exp_pakd.adb exp_pakd.ads exp_prag.adb ! exp_prag.ads exp_smem.adb exp_smem.ads exp_strm.adb ! exp_strm.ads exp_tss.adb exp_tss.ads exp_util.adb exp_util.ads ! exp_vfpt.adb exp_vfpt.ads expander.adb expander.ads fe.h ! final.c fmap.adb fmap.ads fname-sf.adb fname-sf.ads ! fname-uf.adb fname-uf.ads fname.adb fname.ads freeze.adb ! freeze.ads frontend.adb frontend.ads g-calend.ads g-comlin.adb ! g-debpoo.adb g-debpoo.ads g-locfil.adb g-os_lib.ads ! g-regist.adb g-regist.ads get_targ.adb get_targ.ads gigi.h ! gmem.c gnat1drv.adb gnat1drv.ads gnat_ug.texi gnatbind.adb ! gnatbind.ads gnatbl.c gnatcmd.adb gnatcmd.ads gnatdll.adb ! gnatfind.adb gnatkr.adb gnatkr.ads gnatlbr.adb gnatlink.adb ! gnatlink.ads gnatls.adb gnatls.ads gnatmake.adb gnatmake.ads ! gnatmem.adb gnatprep.adb gnatprep.ads gnatpsta.adb gnatvsn.ads ! gnatxref.adb hlo.adb hlo.ads hostparm.ads i-c.adb i-cexten.ads ! i-cobol.adb i-cobol.ads i-cpoint.adb i-cpoint.ads i-cpp.adb ! i-cpp.ads i-cstrea.adb i-cstrea.ads i-cstrin.adb i-cstrin.ads ! i-fortra.adb i-os2err.ads i-os2lib.adb i-os2lib.ads ! i-os2syn.ads i-os2thr.ads i-pacdec.adb i-pacdec.ads ! impunit.adb impunit.ads init.c inline.adb inline.ads io-aux.c ! itypes.adb itypes.ads krunch.adb krunch.ads lang-options.h ! lang-specs.h layout.adb layout.ads lib-list.adb lib-load.adb ! lib-load.ads lib-sort.adb lib-util.adb lib-util.ads ! lib-writ.adb lib-writ.ads lib-xref.adb lib-xref.ads lib.adb ! lib.ads link.c live.adb live.ads make.adb make.ads makeusg.adb ! makeusg.ads math_lib.adb mdll.adb mdll.ads memtrack.adb misc.c ! namet.adb namet.ads namet.h nlists.adb nlists.ads nlists.h ! nmake.adb nmake.ads nmake.adt opt.adb opt.ads osint.adb ! osint.ads output.adb output.ads par-ch10.adb par-ch11.adb ! par-ch12.adb par-ch13.adb par-ch2.adb par-ch3.adb par-ch4.adb ! par-ch5.adb par-ch6.adb par-ch7.adb par-ch8.adb par-ch9.adb ! par-endh.adb par-labl.adb par-load.adb par-prag.adb ! par-sync.adb par-tchk.adb par-util.adb par.adb par.ads ! prj-attr.adb prj-attr.ads prj-com.adb prj-com.ads prj-dect.adb ! prj-dect.ads prj-env.adb prj-env.ads prj-ext.adb prj-ext.ads ! prj-nmsc.adb prj-nmsc.ads prj-pars.adb prj-pars.ads ! prj-part.adb prj-part.ads prj-proc.adb prj-proc.ads ! prj-strt.adb prj-strt.ads prj-tree.adb prj-tree.ads ! prj-util.adb prj-util.ads prj.adb prj.ads raise.c raise.h ! repinfo.adb repinfo.ads repinfo.h restrict.adb restrict.ads ! rident.ads rtsfind.adb rtsfind.ads s-addima.adb s-addima.ads ! s-arit64.adb s-arit64.ads s-assert.adb s-assert.ads ! s-asthan.adb s-asthan.ads s-atacco.adb s-auxdec.adb ! s-auxdec.ads s-bitops.adb s-bitops.ads s-chepoo.ads ! s-direio.adb s-direio.ads s-except.ads s-exctab.adb ! s-exctab.ads s-exnflt.ads s-exngen.adb s-exngen.ads ! s-exnint.ads s-exnlfl.ads s-exnlin.ads s-exnllf.ads ! s-exnlli.ads s-exnsfl.ads s-exnsin.ads s-exnssi.ads ! s-expflt.ads s-expgen.adb s-expgen.ads s-expint.ads ! s-explfl.ads s-explin.ads s-expllf.ads s-explli.ads ! s-expllu.adb s-expllu.ads s-expmod.adb s-expmod.ads ! s-expsfl.ads s-expsin.ads s-expssi.ads s-expuns.adb ! s-expuns.ads s-fatflt.ads s-fatgen.adb s-fatgen.ads ! s-fatlfl.ads s-fatllf.ads s-fatsfl.ads s-ficobl.ads ! s-fileio.adb s-fileio.ads s-finimp.adb s-finimp.ads ! s-finroo.adb s-finroo.ads s-fore.adb s-fore.ads s-imgbiu.adb ! s-imgbiu.ads s-imgboo.adb s-imgboo.ads s-imgcha.adb ! s-imgcha.ads s-imgdec.adb s-imgdec.ads s-imgenu.adb ! s-imgenu.ads s-imgint.adb s-imgint.ads s-imgllb.adb ! s-imgllb.ads s-imglld.adb s-imglld.ads s-imglli.adb ! s-imglli.ads s-imgllu.adb s-imgllu.ads s-imgllw.adb ! s-imgllw.ads s-imgrea.adb s-imgrea.ads s-imguns.adb ! s-imguns.ads s-imgwch.adb s-imgwch.ads s-imgwiu.adb ! s-imgwiu.ads s-inmaop.ads s-interr.adb s-interr.ads ! s-intman.ads s-io.adb s-io.ads s-maccod.ads s-mantis.adb ! s-mantis.ads s-memory.adb s-memory.ads s-osprim.ads ! s-pack03.adb s-pack03.ads s-pack05.adb s-pack05.ads ! s-pack06.adb s-pack06.ads s-pack07.adb s-pack07.ads ! s-pack09.adb s-pack09.ads s-pack10.adb s-pack10.ads ! s-pack11.adb s-pack11.ads s-pack12.adb s-pack12.ads ! s-pack13.adb s-pack13.ads s-pack14.adb s-pack14.ads ! s-pack15.adb s-pack15.ads s-pack17.adb s-pack17.ads ! s-pack18.adb s-pack18.ads s-pack19.adb s-pack19.ads ! s-pack20.adb s-pack20.ads s-pack21.adb s-pack21.ads ! s-pack22.adb s-pack22.ads s-pack23.adb s-pack23.ads ! s-pack24.adb s-pack24.ads s-pack25.adb s-pack25.ads ! s-pack26.adb s-pack26.ads s-pack27.adb s-pack27.ads ! s-pack28.adb s-pack28.ads s-pack29.adb s-pack29.ads ! s-pack30.adb s-pack30.ads s-pack31.adb s-pack31.ads ! s-pack33.adb s-pack33.ads s-pack34.adb s-pack34.ads ! s-pack35.adb s-pack35.ads s-pack36.adb s-pack36.ads ! s-pack37.adb s-pack37.ads s-pack38.adb s-pack38.ads ! s-pack39.adb s-pack39.ads s-pack40.adb s-pack40.ads ! s-pack41.adb s-pack41.ads s-pack42.adb s-pack42.ads ! s-pack43.adb s-pack43.ads s-pack44.adb s-pack44.ads ! s-pack45.adb s-pack45.ads s-pack46.adb s-pack46.ads ! s-pack47.adb s-pack47.ads s-pack48.adb s-pack48.ads ! s-pack49.adb s-pack49.ads s-pack50.adb s-pack50.ads ! s-pack51.adb s-pack51.ads s-pack52.adb s-pack52.ads ! s-pack53.adb s-pack53.ads s-pack54.adb s-pack54.ads ! s-pack55.adb s-pack55.ads s-pack56.adb s-pack56.ads ! s-pack57.adb s-pack57.ads s-pack58.adb s-pack58.ads ! s-pack59.adb s-pack59.ads s-pack60.adb s-pack60.ads ! s-pack61.adb s-pack61.ads s-pack62.adb s-pack62.ads ! s-pack63.adb s-pack63.ads s-parame.adb s-parame.ads ! s-parint.adb s-parint.ads s-pooglo.adb s-pooglo.ads ! s-pooloc.adb s-pooloc.ads s-poosiz.adb s-poosiz.ads ! s-powtab.ads s-proinf.adb s-proinf.ads s-rpc.adb s-rpc.ads ! s-scaval.ads s-secsta.adb s-secsta.ads s-sequio.adb ! s-sequio.ads s-shasto.adb s-shasto.ads s-soflin.adb ! s-soflin.ads s-sopco3.adb s-sopco3.ads s-sopco4.adb ! s-sopco4.ads s-sopco5.adb s-sopco5.ads s-stache.adb ! s-stache.ads s-stalib.adb s-stalib.ads s-stoele.adb ! s-stopoo.ads s-stratt.adb s-stratt.ads s-strops.adb ! s-strops.ads s-taprob.ads s-taprop.ads s-tarest.ads ! s-tasdeb.adb s-tasdeb.ads s-tasinf.adb s-tasinf.ads ! s-tasini.ads s-taskin.ads s-tasren.ads s-tasres.ads ! s-tassta.ads s-tpinop.adb s-tpinop.ads s-tpoben.ads ! s-tpobop.ads s-unstyp.ads s-vaflop.adb s-vaflop.ads ! s-valboo.adb s-valboo.ads s-valcha.adb s-valcha.ads ! s-valdec.adb s-valdec.ads s-valenu.adb s-valenu.ads ! s-valint.adb s-valint.ads s-vallld.adb s-vallld.ads ! s-vallli.adb s-vallli.ads s-valllu.adb s-valllu.ads ! s-valrea.adb s-valrea.ads s-valuns.adb s-valuns.ads ! s-valuti.adb s-valuti.ads s-valwch.adb s-valwch.ads ! s-vercon.adb s-vercon.ads s-vmexta.adb s-vmexta.ads ! s-wchcnv.adb s-wchcnv.ads s-wchcon.ads s-wchjis.adb ! s-wchjis.ads s-wchstw.adb s-wchstw.ads s-wchwts.adb ! s-wchwts.ads s-widboo.adb s-widboo.ads s-widcha.adb ! s-widcha.ads s-widenu.adb s-widenu.ads s-widlli.adb ! s-widlli.ads s-widllu.adb s-widllu.ads s-widwch.adb ! s-widwch.ads s-wwdcha.adb s-wwdcha.ads s-wwdenu.adb ! s-wwdenu.ads s-wwdwch.adb s-wwdwch.ads scans.adb scans.ads ! scn-nlit.adb scn-slit.adb scn.adb scn.ads sdefault.ads sem.adb ! sem.ads sem_aggr.adb sem_aggr.ads sem_attr.adb sem_attr.ads ! sem_case.adb sem_case.ads sem_cat.adb sem_cat.ads sem_ch10.adb ! sem_ch10.ads sem_ch11.adb sem_ch11.ads sem_ch12.adb ! sem_ch12.ads sem_ch13.adb sem_ch13.ads sem_ch2.adb sem_ch2.ads ! sem_ch3.adb sem_ch3.ads sem_ch4.adb sem_ch4.ads sem_ch5.adb ! sem_ch5.ads sem_ch6.adb sem_ch6.ads sem_ch7.adb sem_ch7.ads ! sem_ch8.adb sem_ch8.ads sem_ch9.adb sem_ch9.ads sem_disp.adb ! sem_disp.ads sem_dist.adb sem_dist.ads sem_elab.adb ! sem_elab.ads sem_elim.adb sem_elim.ads sem_eval.adb ! sem_eval.ads sem_intr.adb sem_intr.ads sem_maps.adb ! sem_maps.ads sem_mech.adb sem_mech.ads sem_prag.adb ! sem_prag.ads sem_res.adb sem_res.ads sem_smem.adb sem_smem.ads ! sem_type.adb sem_type.ads sem_util.adb sem_util.ads ! sem_vfpt.adb sem_vfpt.ads sem_warn.adb sem_warn.ads ! sfn_scan.adb sfn_scan.ads sinfo-cn.adb sinfo-cn.ads sinfo.adb ! sinfo.ads sinfo.h sinput-l.adb sinput-l.ads sinput-p.adb ! sinput-p.ads sinput.adb sinput.ads snames.adb snames.ads ! snames.h sprint.adb sprint.ads stand.adb stand.ads stringt.adb ! stringt.ads stringt.h style.adb style.ads stylesw.adb ! stylesw.ads switch.adb switch.ads sysdep.c system.ads ! table.adb table.ads targparm.adb targparm.ads targtyps.c ! tbuild.adb tbuild.ads trans.c tree_gen.adb tree_gen.ads ! tree_in.adb tree_in.ads tree_io.adb tree_io.ads treepr.adb ! treepr.ads treeprs.ads treeprs.adt ttypef.ads ttypes.ads ! types.adb types.ads types.h uintp.adb uintp.ads uintp.h ! uname.adb uname.ads urealp.adb urealp.ads urealp.h usage.adb ! usage.ads utils.c utils2.c validsw.adb validsw.ads ! widechar.adb widechar.ads xeinfo.adb xnmake.adb xr_tabls.adb ! xr_tabls.ads xref_lib.adb xref_lib.ads xsinfo.adb xsnames.adb ! xtreeprs.adb: Correct statements in comments about maintainership ! of GNAT. ! ! 2002-09-23 Zack Weinberg ! ! * Make-lang.in (EXTRA_GNATBIND_OBJS): Add version.o. ! * Makefile.in (TOOLS_LIBS): Add ../../version.o. ! * gnatvsn.ads: Gnat_Version_String is now a function. ! * gnatvsn.adb: New file. When asked for Gnat_Version_String, ! copy the C version_string into a String and return it. ! * gnatcmd.adb, gnatkr.adb, gnatlbr.adb, gnatlink.adb, ! gnatls.adb,gnatmake.adb, gnatprep.adb, gnatpsta.adb: ! Remove pragma Ident (Gnat_Version_String). If this was the ! sole use of package Gnatvsn, remove the with statement too. ! * gnat1drv.adb: Tweak -gnatv output. ! ! 2002-09-17 Richard Henderson ! ! * trans.c (tree_transform): Use real_ldexp not REAL_VALUE_LDEXP. ! * config/dsp16xx/dsp16xx.md (fixuns_trunchfhi2): Use real_2expN. ! * config/mips/mips.md (fixuns_truncdfsi2): Likewise. ! (fixuns_truncdfdi2, fixuns_truncsfsi2, fixuns_truncsfdi2): Likewise. ! * config/m68k/m68k.c (floating_exact_log2): Use real_exponent ! and real_2expN instead of a loop. ! * doc/tm.texi (REAL_VALUE_LDEXP): Remove. ! (REAL_VALUE_RNDZINT, REAL_VALUE_UNSIGNED_RNDZINT): Remove. 2002-08-25 Andre Leis ! David Billinghurst (David.Billinghurst@riotinto.com> ! * sysdep.c (__gnat_ttyname): include on cygwin ! 2002-08-13 Rainer Orth ! * Make-lang.in (gnatbind$(exeext)): Link with $(SYSLIBS). ! Remove $(CONFIG_H) dependency. ! 2002-08-08 Nathan Sidwell ! * ada/Make-lang.in (ada.mostlyclean): Remove coverage files. ! 2002-07-29 Kaveh R. Ghazi ! * adadecode.c (ada_demangle): Use xstrdup in lieu of ! xmalloc/strcpy. ! * misc.c (gnat_decode_option): Likewise. ! 2002-07-15 Florian Weimer ! * make.adb (Add_Switch): Make Generic_Position a procedure. The ! function approach did not work well because of a side effect (the ! function call could reallocate the table which was being indexed ! using its result). Fixes ada/4851. [RESURRECTED] ! 2002-07-01 Roger Sayle ! * ada/utils.c (builtin_function): Accept an additional parameter. ! 2002-06-28 Andreas Jaeger ! PR ada/7144 ! * Makefile.in: Fix typo in comment, patch by Adrian Knoth ! . ! 2002-06-24 Kaveh R. Ghazi ! * Makefile.in (SHELL): Set to @SHELL@. ! 2002-06-20 Kaveh R. Ghazi ! * utils.c (init_gigi_decls): Use ARRAY_SIZE in lieu of explicit ! array size calculation. ! 2002-06-04 Andreas Jaeger ! * Make-lang.in (gnatbind): Readd rule that has been lost in last ! patch. ! 2002-06-03 Geoffrey Keating ! Merge from pch-branch: ! * config-lang.in (gtfiles): Add ada-tree.h. ! * ada-tree.h (SET_TYPE_CI_CO_LIST): New. ! (SET_TYPE_MODULUS): New. ! (SET_TYPE_INDEX): New. ! (SET_TYPE_DIGITS_VALUE): New. ! (SET_TYPE_RM_SIZE): New. ! (SET_TYPE_UNCONSTRAINED_ARRAY): New. ! (SET_TYPE_ADA_SIZE): New. ! (SET_TYPE_ACTUAL_BOUNDS): New. ! (SET_DECL_CONST_CORRESPONDING_VAR): New. ! (SET_DECL_ORIGINAL_FIELD): New. ! (TREE_LOOP_ID): Correct typo. ! * decl.c: Use new macros. ! * utils.c: Include debug.h, use new macros. ! * utils2.c: Use new macros. ! * ada-tree.h: Update all macros for new tree description. ! (struct tree_loop_id): New. ! (union lang_tree_node): New. ! (struct lang_decl): New. ! (struct lang_type): New. ! * misc.c (gnat_mark_tree): Delete. ! (LANG_HOOKS_MARK_TREE): Delete. ! * trans.c (tree_transform): No longer any need to cast ! for TREE_LOOP_ID. ! * utils.c (struct language_function): New dummy structure. ! * Makefile.in (decl.o): gt-ada- is in objdir, not srcdir. ! (misc.o): Likewise. ! (utils.o): Likewise; also gtype-ada.h. ! * Make-lang.in (gnat1): Add dependency on s-gtype. ! (gnatbind): Add dependency on $(CONFIG_H). ! * utils.c: Correct last #include. ! (stuct e_stack): Remove unnecessary 'static'. ! (mark_e_stack): Remove unused prototype. ! * scn-nlit.adb: Remove whitespace after version number to ! keep lines under 80 chars. ! * snames.adb: Likewise. ! * treepr.ads: Likewise. ! * Makefile.in (decl.o): Include gt-ada-.h. ! (misc.o): Likewise. ! (utils.o): Include gt-ada-.h and gtype-ada.h. ! * config-lang.in (gtfiles): New. ! * decl.c: Use gengtype for roots. ! * gigi.h: Use gengtype for roots. ! * trans.c: Use gengtype for roots. ! * utils.c: Use gengtype for roots, marking. Include gtype-ada.h. ! ! 2002-06-02 Gabriel Dos Reis ! ! * misc.c (gnat_init): Adjust setting of internal_error_function. ! ! 2002-06-01 Joseph S. Myers ! ! * gnat_ug.texi: Use @ifnottex instead of @ifinfo. ! * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, ! gnat_ug_wnt.texi: Regenerate. ! ! 2002-05-31 Florian Weimer ! ! * 5ntaprop.adb (with System.OS_Primitives): Remove. ! ! * cstreams.c (max_path_len): Move from here ... ! * adaint.c (__gnat_max_path_len): ... to here. ! * adaint.c (__gnat_max_path_len): Declare. ! * g-dirope.adb (Max_Path): Adjust. ! * g-os_lib.adb (Normalize_Pathname.Max_Path): Adjust. ! * i-cstrea.ads (max_path_len): Adjust. ! * osint.adb (Get_RTS_Search_Dir.Max_Path): Adjust. ! * xr_tabls.adb (Dir_Name.Max_Path: Adjust. ! ! * Makefile.in, Make-lang.in: Documentation is now built in ! Make-lang.in. Store Info and generated Texinfo files in the ! source directory. ! * gnat_ug.texi: Remove CVS keywords, correct version number. ! Set file name correctly. ! ! * gnat_ug_*.texi: Add. ! * .cvsignore: Ignore generated Texinfo files. ! ! 2002-05-30 Zack Weinberg ! ! * ada.h: Add MI guard macro. ! (SUBTYPE): Define constants with an anonymous enum, not static ! const variables. ! (IN): Cast constants to appropriate type before use. ! ! 2002-05-26 Joseph S. Myers ! ! * gnatvsn.ads (Gnat_Version_String): Change to "3.2 20020526 ! (experimental)". ! ! 2002-05-23 Rainer Orth ! ! * Make-lang.in (CP, ECHO): Copy from Makefile.in. ! (X_ADA_CFLAGS, T_ADA_CFLAGS, X_ADAFLAGS, T_ADAFLAGS): Likewise. ! (ALL_ADAFLAGS, FORCE_DEBUG_ADAFLAGS, ADA_CFLAGS): Likewise. ! (ALL_ADA_CFLAGS): Likewise. ! (ADA_INCLUDES): Likewise. ! Adapt for new working dir. ! (GNATBIND): Use Makefile.in version. ! (.SUFFIXES): Copy from Makefile.in. ! (ada-warn): Define. ! (.adb.o, .ads.o): Copy from Makefile.in. ! Added $(OUTPUT_OPTION). ! (GNAT1_C_OBJS): Moved from Makefile.in. ! Prefix with ada subdir. ! (GNAT_ADA_OBJS, GNAT1_ADA_OBJS, GNAT1_OBJS, GNATBIND_OBJS): Likewise. ! (EXTRA_GNAT1_OBJS): Moved from Makefile.in. ! Adapt for new working dir. ! (EXTRA_GNATBIND_OBJS): Likewise. ! (ADA_BACKEND): Moved from Makefile.in. ! Renamed to avoid conflict with global BACKEND. ! Use that one. ! (TARGET_ADA_SRCS): Moved from Makefile.in. ! (gnat1$(exeext)): Replaced recursive rule with Makefile.in version. ! Use ADA_BACKEND. ! (gnatbind$(exeext)): Replaced recursive rule with Makefile.in version. ! (ada_extra_files): Moved from Makefile.in. ! Prefix with ada subdir. ! (ada/b_gnat1.c, ada/b_gnat1.o, ada/b_gnatb.c, ada/b_gnatb.o): Likewise. ! (ada/treeprs.ads, ada/einfo.h, ada/sinfo.h, ada/nmake.adb): Likewise. ! (ada/nmake.ads): Likewise. ! (update-sources): Moved from Makefile.in. ! Prefix with ada subdir. ! (ada/sdefault.adb, ada/stamp-sdefault, ada/sdefault.o): Likewise. ! (ADA_TREE_H): Likewise. ! (ada/a-except.o, ada/s-assert.o, ada/s-memory.o): Likewise. ! (ada/memtrack.o): Likewise. ! (ada/adadecode.o): Likewise. ! Update dependencies. ! (ada/adaint.o): New. ! (ada/argv.o): Moved from Makefile.in. ! Prefix with ada subdir. ! Update dependencies. ! (ada/cstreams.o, ada/exit.o, ada/final.o, ada/link.o): Likewise. ! (ada/cio.o, ada/init.o, ada/raise.o, ada/tracebak.o): Likewise. ! (ada/cuintp.o, ada/decl.o, ada/misc.o): Moved from Makefile.in. ! Prefix with ada subdir. ! (ada/targtyps.o, ada/trans.o, ada/utils.o, ada/utils2.o): Likewise. ! (GNAT DEPENDENCIES): Regenerate. ! * Makefile.in (MACHMODE_H, RTL_H, TREE_H): Removed, provided by ! toplevel Makefile.in. ! (EXTRA_GNAT1_OBJS, EXTRA_GNATBIND_OBJS): Removed. ! (TARGET_ADA_SRCS): Removed. ! (GNAT1_C_OBJS, GNAT_ADA_OBJS, GNAT1_ADA_OBJS, GNAT1_OBJS): Likewise. ! (GNATBIND_OBJS): Likewise. ! (ADA_INCLUDE_DIR, ADA_RTL_OBJ_DIR): Moved here. ! (BACKEND): Removed. ! (../gnat1$(exeext), ../gnatbind$(exeext)): Likewise. ! (TREE_H): Likewise. ! (ada_extra_files): Likewise. ! (b_gnat1.c, b_gnat1.o, b_gnatb.c, b_gnatb.o): Likewise. ! (treeprs.ads, einfo.h, sinfo.h, nmake.adb, nmake.ads): Likewise. ! (update-sources): Likewise. ! (sdefault.adb, stamp-sdefault, sdefault.o): Likewise ! (ADA_TREE_H): Likewise. ! (adadecoce.o): Likewise. ! (cuintp.o, decl.o, misc.o, trans.o, utils.o, utils2.o): Likewise. ! (GNAT DEPENDENCIES): Likewise. ! ! 2002-05-16 Rainer Orth ! ! * Makefile.adalib: Allow for PWDCMD to override hardcoded pwd. ! * Makefile.in: Likewise. ! ! 2002-05-14 Rainer Orth ! ! * Make-lang.in (gnat1$(exeext), gnatbind$(exeext), gnattools): ! Restore $(CONFIG_H) and prefix.o dependencies. ! (ada.stage[1-4]): Depend on stage?-start. ! ! * Makefile.in (b_gnatb.c): Depend on interfac.o. ! ! 2002-05-02 Jim Wilson ! ! * utils.c (finish_record_type): Change record_size to record_type. ! ! 2001-05-02 John David Anglin ! ! * ada/Makefile.in (X_ADA_CFLAGS, T_ADA_CFLAGS): New fragment overrides. ! (ALL_ADA_CFLAGS): Define. Replace ADA_CFLAGS with ALL_ADA_CFLAGS in ! ALL_ADAFLAGS, MOST_ADAFLAGS, and all compilations using CC. ! ! 2002-04-25 Neil Booth ! ! * misc.c (gnat_parse_file): Update. ! ! 2002-04-24 Neil Booth ! ! * misc.c (gnat_init): Don't set lang_attribute_common. 2002-04-21 Joseph S. Myers *************** *** 503,527 **** * xgnatug.adb, ug_words: New files. * Makefile.in (doc, dvi): New targets. Build gnat_ug_*, ! gnat_rm and gnat-style manuals. ! * adaint.c (__gnat_tmp_name): Remove buffer overflow bug on ! GNU/Linux. 2002-04-16 Mark Mitchell * trans.c (tree_transform): Add has_scope argument to expand_start_stmt_expr. 2002-04-04 Laurent Guerby * make.adb: Implement -margs, remove restriction about file name placement. * makeusg.adb: Documentation update. 2002-03-11 Richard Henderson * Makefile.in (.NOTPARALLEL): Add fake tag. 2002-02-07 Richard Henderson * adaint.c (__gnat_to_gm_time): First arg is int, not time_t. --- 705,1039 ---- * xgnatug.adb, ug_words: New files. * Makefile.in (doc, dvi): New targets. Build gnat_ug_*, ! gnat_rm and gnat-style manuals. ! 2002-04-18 Neil Booth ! ! * gigi.h (incomplete_type_error): Remove. ! * utils.c (incomplete_type_error): Remove. 2002-04-16 Mark Mitchell * trans.c (tree_transform): Add has_scope argument to expand_start_stmt_expr. + 2002-04-04 Neil Booth + + * gigi.h (truthvalue_conversion): Rename. + * misc.c (LANG_HOOKS_TRUTHVALUE_CONVERSION): Redefine. + * trans.c (tree_transform): Update. + * utils2.c (truthvalue_conversion): Rename, update. + (build_binary_op, build_unary_op): Update. + 2002-04-04 Laurent Guerby * make.adb: Implement -margs, remove restriction about file name placement. * makeusg.adb: Documentation update. + * Makefile.in (TOOLS_FLAGS_TO_PASS): Add VPATH=$(fsrcdir). + * Makefile.in (gnattools3): Comment out, gnatmem does not build without libaddr2line. + + 2002-04-04 Neil Booth + + * utils.c (create_subprog_decl): Use SET_DECL_ASSEMBLER_NAME. + (builtin_function): Similarly. + + 2002-04-01 Neil Booth + + * decl.c (gnat_to_gnu_entity): Update. + * gigi.h (mark_addressable): Rename. + * misc.c (LANG_HOOKS_MARK_ADDRESSABLE): Redefine. + * trans.c (tree_transform): Update. + * utils.c (create_var_decl): Update. + * util2.c (build_binary_op, build_unary_op, + fill_vms_descriptor): Update. + (mark_addressable): Rename, update. + + 2002-04-01 Neil Booth + + * gigi.h (unsigned_type, signed_type, signed_or_unsigned_type): + Rename. + * misc.c (LANG_HOOKS_SIGNED_TYPE, LANG_HOOKS_UNSIGNED_TYPE, + LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE): New. + * trans.c (tree_transform, convert_with_check): Update. + * utils.c (unsigned_type, signed_type, signed_or_unsigned_type): + Rename. + + 2002-03-31 Neil Booth + + * gigi.h (finish_incomplete_decl): Rename. + * misc.c (LANG_HOOKS_FINISH_INCOMPLETE_DECL): Redefine. + * utils.c (gnat_init_decl_processing): Don't set hook. + (finish_incomplete_decl): Rename. + + 2002-03-29 Andreas Schwab + + * Makefile.in: Pass VPATH=$(fsrcdir) when calling make in rts + directory. + + 2001-03-28 Robert Dewar + + * checks.ads: + (Remove_Checks): New procedure + + * checks.adb: + (Remove_Checks): New procedure + + * exp_util.adb: + Use new Duplicate_Subexpr functions + (Duplicate_Subexpr_No_Checks): New procedure + (Duplicate_Subexpr_No_Checks_Orig): New procedure + (Duplicate_Subexpr): Restore original form (checks duplicated) + (Duplicate_Subexpr): Call Remove_Checks + + * exp_util.ads: + (Duplicate_Subexpr_No_Checks): New procedure + (Duplicate_Subexpr_No_Checks_Orig): New procedure + Add 2002 to copyright notice + + * sem_util.adb: Use new Duplicate_Subexpr functions + + * sem_eval.adb: + (Eval_Indexed_Component): This is the place to call + Constant_Array_Ref and to replace the value. We simply merge + the code of this function in here, since it is now no longer + used elsewhere. This fixes the problem of the back end not + realizing we were clever enough to see that this was + constant. + (Expr_Val): Remove call to Constant_Array_Ref + (Expr_Rep_Val): Remove call to Constant_Array_Ref + Minor reformatting + (Constant_Array_Ref): Deal with string literals (patch + suggested by Zack Weinberg on the gcc list) + + 2001-03-28 Ed Schonberg + + * exp_util.adb: Duplicate_Subexpr_No_Checks_Orig => + Duplicate_Subexpr_Move_Checks. + + * exp_util.ads: Duplicate_Subexpr_No_Checks_Orig => + Duplicate_Subexpr_Move_Checks. + + * sem_eval.adb: (Constant_Array_Ref): Verify that constant + value of array exists before retrieving it (it may a private + protected component in a function). + + 2002-03-28 Geert Bosch + + * prj-pp.adb : New file. + + * prj-pp.ads : New file. + + 2002-03-28 Andreas Jaeger + + * Makefile.in (stamp-sdefault): Fix path for Makefile. + + 2002-03-28 Neil Booth + + * misc.c (gnat_expand_expr): Move prototype. + + 2002-03-27 Neil Booth + + * misc.c (insert_default_attributes): Remove. + + 2002-03-27 Neil Booth + + * misc.c (LANG_HOOKS_EXPAND_EXPR): Redefine. + (gnat_init): Don't set hook. + (gnat_expand_expr): Fix prototype. + + 2002-03-27 Neil Booth + + * misc.c (ggc_p): Remove. + + 2002-03-27 Geert Bosch + + * prj-makr.ads, prj-makr.adb : New files. + + 2002-03-26 Neil Booth + + * misc.c (LANG_HOOKS_MARK_TREE): Redefine. + (lang_mark_tree): Make static, rename. + + 2002-03-25 Neil Booth + + * misc.c (maybe_build_cleanup): Remove. + + 2002-03-24 Neil Booth + + * gigi.h (yyparse): Remove. + + 2002-03-23 Florian Weimer + + * gnat_rm.texi: Sync with ACT version. + (From Ben Brosgol ) + + 2002-03-20 Neil Booth + + * misc.c (LANG_HOOKS_DECL_PRINTABLE_NAME): Redefine. + (gnat_init): Remove old hook. + + 2002-03-17 Neil Booth + + * misc.c (LANG_HOOKS_PARSE_FILE): Redefine. + (yyparse): Rename gnat_parse_file. + + 2002-03-14 Geoffrey Keating + + Delete all lines containing "$Revision:". + * xeinfo.adb: Don't look for revision numbers. + * xnmake.adb: Likewise. + * xsinfo.adb: Likewise. + * xsnames.adb: Likewise. + * xtreeprs.adb: Likewise. + + 2002-03-12 Kaveh R. Ghazi + + * misc.c (gnat_tree_code_type, gnat_tree_code_length, + gnat_tree_code_name): Delete. + (tree_code_type, tree_code_length, tree_code_name): Define. + (gnat_init): Don't try to copy into the various tree_code + arrays. 2002-03-11 Richard Henderson * Makefile.in (.NOTPARALLEL): Add fake tag. + 2002-03-07 Geert Bosch + + * adadecode.c, adadecode.h, aux-io.c, s-traces.adb, s-traces.ads, + s-tratas.adb, s-tratas.ads, sinput-d.adb, sinput-d.ads, + switch-b.adb, switch-b.ads, switch-c.adb, switch-c.ads, + switch-m.adb, switch-m.ads : New files. + + 2002-03-07 Geert Bosch + + * 41intnam.ads, 42intnam.ads, 4aintnam.ads, 4cintnam.ads, + 4dintnam.ads, 4gintnam.ads, 4hintnam.ads, 4lintnam.ads, + 4mintnam.ads, 4pintnam.ads, 4rintnam.ads, 4sintnam.ads, + 4uintnam.ads, 4vcalend.adb, 4zintnam.ads, 52system.ads, + 5amastop.adb, 5asystem.ads, 5ataprop.adb, 5atpopsp.adb, + 5avxwork.ads, 5bosinte.adb, 5bsystem.ads, 5esystem.ads, + 5fsystem.ads, 5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, + 5gsystem.ads, 5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, + 5hparame.ads, 5hsystem.ads, 5htaprop.adb, 5htraceb.adb, + 5itaprop.adb, 5ksystem.ads, 5kvxwork.ads, 5lintman.adb, + 5lsystem.ads, 5mvxwork.ads, 5ninmaop.adb, 5nosinte.ads, + 5ntaprop.adb, 5ointerr.adb, 5omastop.adb, 5oosinte.adb, + 5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5pvxwork.ads, + 5qtaprop.adb, 5sintman.adb, 5ssystem.ads, 5staprop.adb, + 5stpopse.adb, 5svxwork.ads, 5tosinte.ads, 5uintman.adb, + 5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vintman.adb, + 5vmastop.adb, 5vparame.ads, 5vsystem.ads, 5vtaprop.adb, + 5vtpopde.adb, 5wmemory.adb, 5wsystem.ads, 5wtaprop.adb, + 5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb, + 5zosinte.ads, 5zsystem.ads, 5ztaprop.adb, 6vcpp.adb, 6vcstrea.adb, + 7sintman.adb, 7staprop.adb, 7stpopsp.adb, 9drpc.adb, + Make-lang.in, Makefile.in, a-caldel.adb, a-comlin.ads, + a-dynpri.adb, a-except.adb, a-except.ads, a-finali.adb, + a-ncelfu.ads, a-reatim.adb, a-retide.adb, a-stream.ads, + a-ststio.adb, a-ststio.ads, a-stwifi.adb, a-tags.adb, a-tasatt.adb, + a-textio.adb, a-tideau.adb, a-tiflau.adb, a-tigeau.adb, + a-tigeau.ads, a-tiinau.adb, a-timoau.adb, a-witeio.adb, + a-wtdeau.adb, a-wtenau.adb, a-wtflau.adb, a-wtgeau.adb, + a-wtgeau.ads, a-wtinau.adb, a-wtmoau.adb, ada-tree.def, ada-tree.h, + adaint.c, adaint.h, ali-util.adb, ali.adb, ali.ads, atree.adb, + atree.ads, atree.h, back_end.adb, bcheck.adb, bindgen.adb, + bindusg.adb, checks.adb, comperr.adb, config-lang.in, csets.adb, + csets.ads, cstand.adb, cstreams.c, debug.adb, debug.ads, decl.c, + einfo.adb, einfo.ads, einfo.h, elists.h, errout.adb, errout.ads, + eval_fat.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb, + exp_ch12.adb, exp_ch13.adb, exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, + exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads, + exp_ch9.adb, exp_ch9.ads, exp_dbug.adb, exp_dbug.ads, exp_disp.ads, + exp_dist.adb, exp_fixd.adb, exp_intr.adb, exp_pakd.adb, + exp_prag.adb, exp_strm.adb, exp_util.adb, exp_util.ads, + expander.adb, expect.c, fe.h, fmap.adb, fmap.ads, fname-uf.adb, + freeze.adb, frontend.adb, g-awk.adb, g-cgideb.adb, g-comlin.adb, + g-comlin.ads, g-debpoo.adb, g-dirope.adb, g-dirope.ads, + g-dyntab.adb, g-expect.adb, g-expect.ads, g-io.ads, g-io_aux.adb, + g-io_aux.ads, g-locfil.adb, g-locfil.ads, g-os_lib.adb, + g-os_lib.ads, g-regexp.adb, g-regpat.adb, g-socket.adb, + g-socket.ads, g-spipat.adb, g-table.adb, g-trasym.adb, + g-trasym.ads, gigi.h, gmem.c, gnat1drv.adb, gnatbind.adb, gnatbl.c, + gnatchop.adb, gnatcmd.adb, gnatdll.adb, gnatfind.adb, gnatlbr.adb, + gnatlink.adb, gnatls.adb, gnatmem.adb, gnatprep.adb, gnatvsn.ads, + gnatxref.adb, hlo.adb, hostparm.ads, i-cobol.adb, i-cpp.adb, + i-cstrea.ads, i-cstrin.adb, i-pacdec.adb, i-vxwork.ads, + impunit.adb, init.c, inline.adb, io-aux.c, layout.adb, lib-load.adb, + lib-util.adb, lib-writ.adb, lib-writ.ads, lib-xref.adb, + lib-xref.ads, lib.adb, lib.ads, make.adb, makeusg.adb, mdll.adb, + memroot.adb, misc.c, mlib-tgt.adb, mlib-utl.adb, mlib-utl.ads, + mlib.adb, namet.adb, namet.ads, namet.h, nlists.h, nmake.adb, + nmake.ads, nmake.adt, opt.adb, opt.ads, osint.adb, osint.ads, + output.adb, output.ads, par-ch2.adb, par-ch3.adb, par-ch5.adb, + par-prag.adb, par-tchk.adb, par-util.adb, par.adb, prj-attr.adb, + prj-dect.adb, prj-env.adb, prj-env.ads, prj-nmsc.adb, prj-part.adb, + prj-proc.adb, prj-strt.adb, prj-tree.adb, prj-tree.ads, prj.adb, + prj.ads, raise.c, raise.h, repinfo.adb, restrict.adb, restrict.ads, + rident.ads, rtsfind.adb, rtsfind.ads, s-arit64.adb, s-asthan.adb, + s-atacco.adb, s-atacco.ads, s-auxdec.adb, s-crc32.adb, s-crc32.ads, + s-direio.adb, s-fatgen.adb, s-fileio.adb, s-finimp.adb, + s-gloloc.adb, s-gloloc.ads, s-interr.adb, s-mastop.adb, + s-mastop.ads, s-memory.adb, s-parame.ads, s-parint.adb, + s-pooglo.adb, s-pooloc.adb, s-rpc.adb, s-secsta.adb, s-sequio.adb, + s-shasto.adb, s-soflin.adb, s-soflin.ads, s-stache.adb, + s-taasde.adb, s-taasde.ads, s-tadeca.adb, s-tadeca.ads, + s-tadert.adb, s-tadert.ads, s-taenca.adb, s-taenca.ads, + s-taprob.adb, s-taprop.ads, s-tarest.adb, s-tasdeb.adb, + s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads, + s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads, + s-tassta.adb, s-tasuti.adb, s-tasuti.ads, s-tataat.adb, + s-tataat.ads, s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, + s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads, + s-unstyp.ads, s-widenu.adb, scn-nlit.adb, scn.adb, sem.adb, + sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb, + sem_ch10.adb, sem_ch11.adb, sem_ch11.ads, sem_ch12.adb, + sem_ch13.adb, sem_ch13.ads, sem_ch2.adb, sem_ch3.adb, sem_ch3.ads, + sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch6.ads, sem_ch7.adb, + sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, sem_disp.adb, sem_dist.adb, + sem_elab.adb, sem_elim.adb, sem_elim.ads, sem_eval.adb, + sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb, + sem_type.adb, sem_util.adb, sem_util.ads, sem_vfpt.adb, + sem_warn.adb, sinfo.adb, sinfo.ads, sinfo.h, sinput-l.adb, + sinput-l.ads, sinput.adb, sinput.ads, snames.adb, snames.ads, + snames.h, sprint.adb, sprint.ads, stringt.adb, stringt.ads, + stringt.h, style.adb, switch.adb, switch.ads, sysdep.c, system.ads, + table.adb, targparm.adb, targparm.ads, targtyps.c, tbuild.adb, + tbuild.ads, tracebak.c, trans.c, tree_gen.adb, tree_io.adb, + treepr.adb, treepr.ads, treeprs.ads, treeprs.adt, ttypes.ads, + types.adb, types.ads, types.h, uintp.ads, urealp.ads, usage.adb, + utils.c, utils2.c, validsw.adb, xnmake.adb, xr_tabls.adb, + xr_tabls.ads, xref_lib.adb, xref_lib.ads : Merge in ACT changes. + + * 1ssecsta.adb, 1ssecsta.ads, a-chlat9.ads, a-cwila9.ads, + g-enblsp.adb, g-md5.adb, g-md5.ads, gnatname.adb, gnatname.ads, + mkdir.c, osint-b.adb, osint-b.ads, osint-c.adb, osint-c.ads, + osint-l.adb, osint-l.ads, osint-m.adb, osint-m.ads : New files + + * 3lsoccon.ads, 5qparame.ads, 5qvxwork.ads, 5smastop.adb, + 5zparame.ads, gnatmain.adb, gnatmain.ads, gnatpsys.adb : Removed + + * mdllfile.adb, mdllfile.ads, mdlltool.adb, mdlltool.ads : Renamed + to mdll-fil.ad[bs] and mdll-util.ad[bs] + + * mdll-fil.adb, mdll-fil.ads, mdll-utl.adb, mdll-utl.ads : Renamed + from mdllfile.ad[bs] and mdlltool.ad[bs] + + 2002-03-03 Kaveh R. Ghazi + + * utils.c (init_gnat_to_gnu, init_gigi_decls): Use ARRAY_SIZE in + lieu of explicit sizeof/sizeof. + + 2002-02-28 Neil Booth + + * misc.c (copy_lang_decl): Remove. + + 2002-02-27 Zack Weinberg + + * misc.c: Delete traditional-mode-related code copied from the + C front end but not used, or used only to permit the compiler + to link. + 2002-02-07 Richard Henderson * adaint.c (__gnat_to_gm_time): First arg is int, not time_t. *************** *** 545,551 **** * gnat-style.texi (Declarations and Types): Remove ancient style rule which was mandated by code generation issues. ! * gnat-style.texi (header): Add @dircategory, @direntry. (title page): Remove date. (general) Add @./@: where approriate, and two spaces after the --- 1057,1063 ---- * gnat-style.texi (Declarations and Types): Remove ancient style rule which was mandated by code generation issues. ! * gnat-style.texi (header): Add @dircategory, @direntry. (title page): Remove date. (general) Add @./@: where approriate, and two spaces after the *************** *** 574,655 **** 2001-12-19 Robert Dewar * bindgen.adb: Minor reformatting ! * cstand.adb: Minor reformatting ! * fmap.adb: Minor reformatting Change name from Add for Add_To_File_Map (Add is much too generic) Change Path_Name_Of to Mapped_Path_Name Change File_Name_Of to Mapped_File_Name Fix copyright dates in header ! * fmap.ads: Change name from Add for Add_To_File_Map (Add is much too generic) Change Path_Name_Of to Mapped_Path_Name Change File_Name_Of to Mapped_File_Name Fix copyright dates in header ! * fname-uf.adb: Minor reformatting. New names of stuff in Fmap. Add use clause for Fmap. ! * make.adb: Minor reformatting ! * osint.adb: Minor reformatting. Change of names in Fmap. Add use clause for Fmap. ! * prj-env.adb: Minor reformatting ! * prj-env.ads: Minor reformatting ! ! * switch.adb: Minor reformatting. Do proper raise of Bad_Switch if ! error found (there were odd exceptions to this general rule in -gnatec/-gnatem processing) ! 2001-12-19 Olivier Hainque ! * raise.c (__gnat_eh_personality): Exception handling personality ! routine for Ada. Still in rough state, inspired from the C++ version and still containing a bunch of debugging artifacts. ! (parse_lsda_header, get_ttype_entry): Local (static) helpers, also inspired from the C++ library. ! ! * raise.c (eh_personality): Add comments. Part of work for the GCC 3 exception handling integration. ! 2001-12-19 Arnaud Charlet * Makefile.in: Remove use of 5smastop.adb which is obsolete. (HIE_SOURCES): Add s-secsta.ad{s,b}. (HIE_OBJS): Add s-fat*.o ! (RAVEN_SOURCES): Remove files that are no longer required. Add interrupt handling files. (RAVEN_MOD): Removed, no longer needed. ! 2001-12-19 Robert Dewar * a-ngelfu.adb: Remove ??? comment for inappropriate Inline_Always Add 2001 to copyright date ! ! * g-regpat.adb: Change pragma Inline_Always to Inline. There is no need to force universal inlining for these cases. ! 2001-12-19 Arnaud Charlet ! * s-taprob.adb: Minor clean ups so that this unit can be used in Ravenscar HI. ! * exp_ch7.adb: Allow use of secondary stack in HI mode. Disallow it when pragma Restrictions (No_Secondary_Stack) is specified. ! 2001-12-19 Vincent Celier ! * prj-tree.ads (Project_Node_Record): Add comments for components Pkg_Id and Case_Insensitive. ! 2001-12-19 Pascal Obry * g-socket.adb: Minor reformatting. Found while reading code. ! 2001-12-19 Robert Dewar * prj-tree.ads: Minor reformatting --- 1086,1167 ---- 2001-12-19 Robert Dewar * bindgen.adb: Minor reformatting ! * cstand.adb: Minor reformatting ! * fmap.adb: Minor reformatting Change name from Add for Add_To_File_Map (Add is much too generic) Change Path_Name_Of to Mapped_Path_Name Change File_Name_Of to Mapped_File_Name Fix copyright dates in header ! * fmap.ads: Change name from Add for Add_To_File_Map (Add is much too generic) Change Path_Name_Of to Mapped_Path_Name Change File_Name_Of to Mapped_File_Name Fix copyright dates in header ! * fname-uf.adb: Minor reformatting. New names of stuff in Fmap. Add use clause for Fmap. ! * make.adb: Minor reformatting ! * osint.adb: Minor reformatting. Change of names in Fmap. Add use clause for Fmap. ! * prj-env.adb: Minor reformatting ! * prj-env.ads: Minor reformatting ! ! * switch.adb: Minor reformatting. Do proper raise of Bad_Switch if ! error found (there were odd exceptions to this general rule in -gnatec/-gnatem processing) ! 2001-12-19 Olivier Hainque ! * raise.c (__gnat_eh_personality): Exception handling personality ! routine for Ada. Still in rough state, inspired from the C++ version and still containing a bunch of debugging artifacts. ! (parse_lsda_header, get_ttype_entry): Local (static) helpers, also inspired from the C++ library. ! ! * raise.c (eh_personality): Add comments. Part of work for the GCC 3 exception handling integration. ! 2001-12-19 Arnaud Charlet * Makefile.in: Remove use of 5smastop.adb which is obsolete. (HIE_SOURCES): Add s-secsta.ad{s,b}. (HIE_OBJS): Add s-fat*.o ! (RAVEN_SOURCES): Remove files that are no longer required. Add interrupt handling files. (RAVEN_MOD): Removed, no longer needed. ! 2001-12-19 Robert Dewar * a-ngelfu.adb: Remove ??? comment for inappropriate Inline_Always Add 2001 to copyright date ! ! * g-regpat.adb: Change pragma Inline_Always to Inline. There is no need to force universal inlining for these cases. ! 2001-12-19 Arnaud Charlet ! * s-taprob.adb: Minor clean ups so that this unit can be used in Ravenscar HI. ! * exp_ch7.adb: Allow use of secondary stack in HI mode. Disallow it when pragma Restrictions (No_Secondary_Stack) is specified. ! 2001-12-19 Vincent Celier ! * prj-tree.ads (Project_Node_Record): Add comments for components Pkg_Id and Case_Insensitive. ! 2001-12-19 Pascal Obry * g-socket.adb: Minor reformatting. Found while reading code. ! 2001-12-19 Robert Dewar * prj-tree.ads: Minor reformatting *************** *** 660,752 **** 2001-12-17 Ed Schonberg ! * sem_res.adb (Resolve_Selected_Component): do not generate a ! discriminant check if the selected component is a component of the argument of an initialization procedure. ! * trans.c (tree_transform, case of arithmetic operators): If result ! type is private, the gnu_type is the base type of the full view, given that the full view itself may be a subtype. ! 2001-12-17 Robert Dewar * sem_res.adb: Minor reformatting ! ! * trans.c (tree_transform, case N_Real_Literal): Add missing third ! parameter in call to Machine (unknown horrible effects from this omission). ! * urealp.h: Add definition of Round_Even for call to Machine Add third parameter for Machine ! 2001-12-17 Ed Schonberg ! * sem_warn.adb (Check_One_Unit): Suppress warnings completely on predefined units in No_Run_Time mode. ! 2001-12-17 Richard Kenner * misc.c (insn-codes.h): Now include. ! 2001-12-17 Olivier Hainque ! * a-except.adb: Preparation work for future integration of the GCC 3 exception handling mechanism (Notify_Handled_Exception, Notify_Unhandled_Exception): New routines to factorize previous code sequences and make them externally callable, e.g. for the Ada personality routine when the GCC 3 mechanism is used. (Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler): Use the new notification routines. ! 2001-12-17 Emmanuel Briot * prj-tree.ads (First_Choice_Of): Document the when others case ! 2001-12-17 Arnaud Charlet ! * bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in HI-E mode, in order to support Ravenscar profile properly. ! ! * cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E mode on 32 bits targets. ! 2001-12-17 Vincent Celier * fmap.adb: Initial version. ! * fmap.ads: Initial version. ! * fname-uf.adb (Get_File_Name): Use mapping if unit name mapped. If search is successfully done, add to mapping. ! * frontend.adb: Initialize the mapping if a -gnatem switch was used. ! * make.adb: (Gnatmake): Add new local variable Mapping_File_Name. Create mapping file when using project file(s). Delete mapping file before exiting. ! * opt.ads (Mapping_File_Name): New variable ! * osint.adb (Find_File): Use path name found in mapping, if any. ! * prj-env.adb (Create_Mapping_File): New procedure ! * prj-env.ads (Create_Mapping_File): New procedure. ! ! * switch.adb (Scan_Front_End_Switches): Add processing for -gnatem (Mapping_File) ! * usage.adb: Add entry for new switch -gnatem. ! * Makefile.in: Add dependencies for fmap.o. ! 2001-12-17 Ed Schonberg ! * sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit is a package instantiation rewritten as a package body. (Install_Withed_Unit): Undo previous change, now redundant. ! 2001-12-17 Gary Dismukes * layout.adb: --- 1172,1264 ---- 2001-12-17 Ed Schonberg ! * sem_res.adb (Resolve_Selected_Component): do not generate a ! discriminant check if the selected component is a component of the argument of an initialization procedure. ! * trans.c (tree_transform, case of arithmetic operators): If result ! type is private, the gnu_type is the base type of the full view, given that the full view itself may be a subtype. ! 2001-12-17 Robert Dewar * sem_res.adb: Minor reformatting ! ! * trans.c (tree_transform, case N_Real_Literal): Add missing third ! parameter in call to Machine (unknown horrible effects from this omission). ! * urealp.h: Add definition of Round_Even for call to Machine Add third parameter for Machine ! 2001-12-17 Ed Schonberg ! * sem_warn.adb (Check_One_Unit): Suppress warnings completely on predefined units in No_Run_Time mode. ! 2001-12-17 Richard Kenner * misc.c (insn-codes.h): Now include. ! 2001-12-17 Olivier Hainque ! * a-except.adb: Preparation work for future integration of the GCC 3 exception handling mechanism (Notify_Handled_Exception, Notify_Unhandled_Exception): New routines to factorize previous code sequences and make them externally callable, e.g. for the Ada personality routine when the GCC 3 mechanism is used. (Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler): Use the new notification routines. ! 2001-12-17 Emmanuel Briot * prj-tree.ads (First_Choice_Of): Document the when others case ! 2001-12-17 Arnaud Charlet ! * bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in HI-E mode, in order to support Ravenscar profile properly. ! ! * cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E mode on 32 bits targets. ! 2001-12-17 Vincent Celier * fmap.adb: Initial version. ! * fmap.ads: Initial version. ! * fname-uf.adb (Get_File_Name): Use mapping if unit name mapped. If search is successfully done, add to mapping. ! * frontend.adb: Initialize the mapping if a -gnatem switch was used. ! * make.adb: (Gnatmake): Add new local variable Mapping_File_Name. Create mapping file when using project file(s). Delete mapping file before exiting. ! * opt.ads (Mapping_File_Name): New variable ! * osint.adb (Find_File): Use path name found in mapping, if any. ! * prj-env.adb (Create_Mapping_File): New procedure ! * prj-env.ads (Create_Mapping_File): New procedure. ! ! * switch.adb (Scan_Front_End_Switches): Add processing for -gnatem (Mapping_File) ! * usage.adb: Add entry for new switch -gnatem. ! * Makefile.in: Add dependencies for fmap.o. ! 2001-12-17 Ed Schonberg ! * sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit is a package instantiation rewritten as a package body. (Install_Withed_Unit): Undo previous change, now redundant. ! 2001-12-17 Gary Dismukes * layout.adb: *************** *** 756,764 **** (Layout_Array_Type): Convert Len expression to Unsigned after calls to Compute_Length and Determine_Range. Above changes fix problem with length computation for supernull arrays ! where Max (Len, 0) wasn't getting applied due to the Unsigned conversion used by Compute_Length. ! 2001-12-17 Arnaud Charlet * rtsfind.ads: --- 1268,1276 ---- (Layout_Array_Type): Convert Len expression to Unsigned after calls to Compute_Length and Determine_Range. Above changes fix problem with length computation for supernull arrays ! where Max (Len, 0) wasn't getting applied due to the Unsigned conversion used by Compute_Length. ! 2001-12-17 Arnaud Charlet * rtsfind.ads: *************** *** 767,837 **** (OK_To_Use_In_Ravenscar_Mode): New table needed to implement Ravenscar in HI-E mode. Remove unused entity RE_Exception_Data. ! * rtsfind.adb (RTE): Allow Ravenscar Profile in HI mode. ! * rident.ads (No_Secondary_Stack): New restriction. 2001-12-17 Joel Brobecker ! * gnat_rm.texi: Fix minor typos. Found while reading the section regarding "Bit_Order Clauses" that was sent to a customer. Very interesting documentation! ! 2001-12-17 Robert Dewar ! * sem_case.adb (Choice_Image): Avoid creating improper character ! literal names by using the routine Set_Character_Literal_Name. This fixes bombs in certain error message cases. ! 2001-12-17 Arnaud Charlet * a-reatim.adb: Minor reformatting. ! 2001-12-17 Ed Schonberg ! * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the ! case where the formal is an extension of another formal in the current unit or in a parent generic unit. ! 2001-12-17 Arnaud Charlet ! * s-tposen.adb: Update comments. Minor reformatting. Minor code clean up. ! * s-tarest.adb: Update comments. Minor code reorganization. ! 2001-12-17 Gary Dismukes ! * exp_attr.adb (Attribute_Tag): Suppress expansion of 'Tag when Java_VM. ! 2001-12-17 Robert Dewar * exp_attr.adb: Minor reformatting ! 2001-12-17 Ed Schonberg ! * sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle derivations nested within a child unit: verify that the parent type is declared in an outer scope. ! 2001-12-17 Robert Dewar * sem_ch12.adb: Minor reformatting ! 2001-12-17 Ed Schonberg ! * sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post ! warning if current unit is a predefined one, from which bodies may have been deleted. ! 2001-12-17 Robert Dewar * eval_fat.ads: Add comment that Round_Even is referenced in Ada code Fix header format. Add 2001 to copyright date. ! ! * exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference, which caused CE during compilation if checks were enabled. 2001-12-17 Vincent Celier --- 1279,1349 ---- (OK_To_Use_In_Ravenscar_Mode): New table needed to implement Ravenscar in HI-E mode. Remove unused entity RE_Exception_Data. ! * rtsfind.adb (RTE): Allow Ravenscar Profile in HI mode. ! * rident.ads (No_Secondary_Stack): New restriction. 2001-12-17 Joel Brobecker ! * gnat_rm.texi: Fix minor typos. Found while reading the section regarding "Bit_Order Clauses" that was sent to a customer. Very interesting documentation! ! 2001-12-17 Robert Dewar ! * sem_case.adb (Choice_Image): Avoid creating improper character ! literal names by using the routine Set_Character_Literal_Name. This fixes bombs in certain error message cases. ! 2001-12-17 Arnaud Charlet * a-reatim.adb: Minor reformatting. ! 2001-12-17 Ed Schonberg ! * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the ! case where the formal is an extension of another formal in the current unit or in a parent generic unit. ! 2001-12-17 Arnaud Charlet ! * s-tposen.adb: Update comments. Minor reformatting. Minor code clean up. ! * s-tarest.adb: Update comments. Minor code reorganization. ! 2001-12-17 Gary Dismukes ! * exp_attr.adb (Attribute_Tag): Suppress expansion of 'Tag when Java_VM. ! 2001-12-17 Robert Dewar * exp_attr.adb: Minor reformatting ! 2001-12-17 Ed Schonberg ! * sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle derivations nested within a child unit: verify that the parent type is declared in an outer scope. ! 2001-12-17 Robert Dewar * sem_ch12.adb: Minor reformatting ! 2001-12-17 Ed Schonberg ! * sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post ! warning if current unit is a predefined one, from which bodies may have been deleted. ! 2001-12-17 Robert Dewar * eval_fat.ads: Add comment that Round_Even is referenced in Ada code Fix header format. Add 2001 to copyright date. ! ! * exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference, which caused CE during compilation if checks were enabled. 2001-12-17 Vincent Celier *************** *** 843,859 **** (Collect_Arguments_And_Compile): Use new function Switches_Of. When using a project file, test if there are any relative search path. Fail if there are any. ! (Gnatmake): Only add switches for the primary directory when not using ! a project file. When using a project file, change directory to the ! object directory of the main project file. When using a project file, ! test if there are any relative search path. Fail if there are any. ! When using a project file, fail if specified executable is relative ! path with directory information, and prepend executable, if not ! specified as an absolute path, with the exec directory. Make sure that only one -o switch is transmitted to the linker. ! * prj-attr.adb (Initialization_Data): Add project attribute Exec_Dir ! * prj-nmsc.adb: (Ada_Check): Get Spec_Suffix_Loc and Impl_Suffix_Loc, when using a non standard naming scheme. --- 1355,1371 ---- (Collect_Arguments_And_Compile): Use new function Switches_Of. When using a project file, test if there are any relative search path. Fail if there are any. ! (Gnatmake): Only add switches for the primary directory when not using ! a project file. When using a project file, change directory to the ! object directory of the main project file. When using a project file, ! test if there are any relative search path. Fail if there are any. ! When using a project file, fail if specified executable is relative ! path with directory information, and prepend executable, if not ! specified as an absolute path, with the exec directory. Make sure that only one -o switch is transmitted to the linker. ! * prj-attr.adb (Initialization_Data): Add project attribute Exec_Dir ! * prj-nmsc.adb: (Ada_Check): Get Spec_Suffix_Loc and Impl_Suffix_Loc, when using a non standard naming scheme. *************** *** 861,941 **** do not raise exceptions. (Is_Illegal_Append): Return True if there is no dot in the suffix. (Language_Independent_Check): Check the exec directory. ! * prj.adb (Project_Empty): Add new component Exec_Directory ! * prj.ads: (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Add defaults. (Project_Data): Add component Exec_Directory ! * snames.adb: Updated to match snames.ads revision 1.215 ! * snames.ads: Added Exec_Dir ! 2001-12-17 Robert Dewar * make.adb: Minor reformatting ! * prj-nmsc.adb: Minor reformatting ! * snames.adb: Updated to match snames.ads ! * snames.ads: Alphebetize entries for project file 2001-12-17 Ed Schonberg ! * trans.c (process_freeze_entity): Do nothing if the entity is a subprogram that was already elaborated. ! 2001-12-17 Richard Kenner ! ! * decl.c (gnat_to_gnu_entity, object): Do not back-annotate Alignment and Esize if object is referenced via pointer. 2001-12-17 Ed Schonberg ! * sem_ch3.adb (Analyze_Variant_Part): check that type of discriminant is discrete before analyzing choices. ! 2001-12-17 Joel Brobecker ! * bindgen.adb (Gen_Output_File_Ada): Generate a new C-like string ! containing the name of the Ada Main Program. This string is mainly intended for the debugger. (Gen_Output_File_C): Do the equivalent change when generating a C file. ! 2001-12-17 Robert Dewar * ali.adb: Set new Dummy_Entry field in dependency entry ! * ali.ads: Add Dummy_Entry field to source dependency table ! * bcheck.adb (Check_Consistency): Ignore dummy D lines ! * lib-writ.adb (Writ_ALI): Write dummy D lines for missing source files ! * lib-writ.ads: Document dummy D lines for missing files. ! * types.ads: (Dummy_Time_Stamp): New value for non-existant files 2001-12-17 Robert Dewar * ali.adb: Type reference does not reset current file. ! * ali.adb: Recognize and scan renaming reference ! * ali.ads: Add spec for storing renaming references. ! * lib-xref.ads: Add documentation for handling of renaming references ! * lib-xref.adb: Implement output of renaming reference. ! * checks.adb: (Determine_Range): Document local variables (Determine_Range): Make sure Hbound is initialized. It looks as though there could be a real problem here with an uninitialized reference to Hbound, but no actual example of failure has been found. ! 2001-12-17 Laurent Pautet * g-socket.ads: --- 1373,1453 ---- do not raise exceptions. (Is_Illegal_Append): Return True if there is no dot in the suffix. (Language_Independent_Check): Check the exec directory. ! * prj.adb (Project_Empty): Add new component Exec_Directory ! * prj.ads: (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Add defaults. (Project_Data): Add component Exec_Directory ! * snames.adb: Updated to match snames.ads revision 1.215 ! * snames.ads: Added Exec_Dir ! 2001-12-17 Robert Dewar * make.adb: Minor reformatting ! * prj-nmsc.adb: Minor reformatting ! * snames.adb: Updated to match snames.ads ! * snames.ads: Alphebetize entries for project file 2001-12-17 Ed Schonberg ! * trans.c (process_freeze_entity): Do nothing if the entity is a subprogram that was already elaborated. ! 2001-12-17 Richard Kenner ! ! * decl.c (gnat_to_gnu_entity, object): Do not back-annotate Alignment and Esize if object is referenced via pointer. 2001-12-17 Ed Schonberg ! * sem_ch3.adb (Analyze_Variant_Part): check that type of discriminant is discrete before analyzing choices. ! 2001-12-17 Joel Brobecker ! * bindgen.adb (Gen_Output_File_Ada): Generate a new C-like string ! containing the name of the Ada Main Program. This string is mainly intended for the debugger. (Gen_Output_File_C): Do the equivalent change when generating a C file. ! 2001-12-17 Robert Dewar * ali.adb: Set new Dummy_Entry field in dependency entry ! * ali.ads: Add Dummy_Entry field to source dependency table ! * bcheck.adb (Check_Consistency): Ignore dummy D lines ! * lib-writ.adb (Writ_ALI): Write dummy D lines for missing source files ! * lib-writ.ads: Document dummy D lines for missing files. ! * types.ads: (Dummy_Time_Stamp): New value for non-existant files 2001-12-17 Robert Dewar * ali.adb: Type reference does not reset current file. ! * ali.adb: Recognize and scan renaming reference ! * ali.ads: Add spec for storing renaming references. ! * lib-xref.ads: Add documentation for handling of renaming references ! * lib-xref.adb: Implement output of renaming reference. ! * checks.adb: (Determine_Range): Document local variables (Determine_Range): Make sure Hbound is initialized. It looks as though there could be a real problem here with an uninitialized reference to Hbound, but no actual example of failure has been found. ! 2001-12-17 Laurent Pautet * g-socket.ads: *************** *** 948,959 **** 2001-12-17 Robert Dewar ! * frontend.adb: Move call to Check_Unused_Withs from Frontend, so that it happens before modification of Sloc values for -gnatD. ! ! * gnat1drv.adb: Move call to Check_Unused_Withs to Frontend, so that it happens before modification of Sloc values for -gnatD. ! * switch.adb: Minor reformatting 2001-12-15 Richard Henderson --- 1460,1471 ---- 2001-12-17 Robert Dewar ! * frontend.adb: Move call to Check_Unused_Withs from Frontend, so that it happens before modification of Sloc values for -gnatD. ! ! * gnat1drv.adb: Move call to Check_Unused_Withs to Frontend, so that it happens before modification of Sloc values for -gnatD. ! * switch.adb: Minor reformatting 2001-12-15 Richard Henderson *************** *** 990,1058 **** 2001-12-14 Vincent Celier ! * osint.adb(Create_Debug_File): When an object file is specified, put the .dg file in the same directory as the object file. ! 2001-12-14 Robert Dewar * osint.adb: Minor reformatting ! ! * lib-xref.adb (Output_Instantiation): New procedure to generate instantiation references. ! * lib-xref.ads: Add documentation of handling of generic references. ! ! * ali.adb (Read_Instantiation_Ref): New procedure to read instantiation references ! * ali.ads: Add spec for storing instantiation references ! * bindusg.adb: Minor reformatting ! * switch.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) ! * usage.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) ! * gnatcmd.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) ! * csets.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) ! * csets.ads: Fix header format Add 2001 to copyright date Add entry for Latin-5 (Cyrillic ISO-8859-5) ! 2001-12-14 Matt Gingell ! * adaint.c: mktemp is a macro on Lynx and can not be used as an expression. ! 2001-12-14 Richard Kenner ! * misc.c (gnat_expand_constant): Do not strip UNCHECKED_CONVERT_EXPR if operand is CONSTRUCTOR. ! 2001-12-14 Ed Schonberg ! * trans.c (tree_transform, case N_Assignment_Statement): Set lineno ! before emiting check on right-hand side, so that exception information is correct. 2001-12-14 Richard Kenner ! ! * utils.c (create_var_decl): Throw away initializing expression if just annotating types and non-constant. ! 2001-12-14 Vincent Celier * prj-nmsc.adb: (Ada_Check): Migrate drom Ada_Default_... to Default_Ada_... ! ! * prj.adb: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix): Remove functions. (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move to spec. ! ! * prj.ads: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix): Remove functions. (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move from body. --- 1502,1570 ---- 2001-12-14 Vincent Celier ! * osint.adb(Create_Debug_File): When an object file is specified, put the .dg file in the same directory as the object file. ! 2001-12-14 Robert Dewar * osint.adb: Minor reformatting ! ! * lib-xref.adb (Output_Instantiation): New procedure to generate instantiation references. ! * lib-xref.ads: Add documentation of handling of generic references. ! ! * ali.adb (Read_Instantiation_Ref): New procedure to read instantiation references ! * ali.ads: Add spec for storing instantiation references ! * bindusg.adb: Minor reformatting ! * switch.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) ! * usage.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) ! * gnatcmd.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) ! * csets.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) ! * csets.ads: Fix header format Add 2001 to copyright date Add entry for Latin-5 (Cyrillic ISO-8859-5) ! 2001-12-14 Matt Gingell ! * adaint.c: mktemp is a macro on Lynx and can not be used as an expression. ! 2001-12-14 Richard Kenner ! * misc.c (gnat_expand_constant): Do not strip UNCHECKED_CONVERT_EXPR if operand is CONSTRUCTOR. ! 2001-12-14 Ed Schonberg ! * trans.c (tree_transform, case N_Assignment_Statement): Set lineno ! before emiting check on right-hand side, so that exception information is correct. 2001-12-14 Richard Kenner ! ! * utils.c (create_var_decl): Throw away initializing expression if just annotating types and non-constant. ! 2001-12-14 Vincent Celier * prj-nmsc.adb: (Ada_Check): Migrate drom Ada_Default_... to Default_Ada_... ! ! * prj.adb: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix): Remove functions. (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move to spec. ! ! * prj.ads: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix): Remove functions. (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move from body. *************** *** 1086,1263 **** 2001-12-12 Ed Schonberg ! * sem_ch12.adb (Save_Entity_Descendant): Use syntactic field names on known node types, rather than untyped fields. Further cleanups. ! 2001-12-12 Robert Dewar * sem_ch12.adb: (Save_Entity_Descendant): Minor comment update. (Copy_Generic_Node): Deal with incorrect reference to Associated_Node ! of an N_Attribute_Reference node. As per note below, this does not eliminate need for Associated_Node in attribute ref nodes. ! (Associated_Node): Documentation explicitly mentions attribute reference nodes, since this field is used in such nodes. ! * sem_ch12.adb (Associated_Node): Minor documentation cleanup. 2001-12-12 Robert Dewar * s-stalib.adb: Add more comments on with statements being needed ! * par-ch12.adb: Minor reformatting ! * prj-dect.ads: Fix copyright header ! ! * s-arit64.adb (Multiply_With_Ovflo_Check): Fix case where both inputs fit in 32 bits, but the result still overflows. ! * s-fatgen.ads: Minor comment improvement ! 2001-12-12 Ed Schonberg ! * sem_ch4.adb (Analyze_Selected_Component): If the prefix is of a ! formal derived type, look for an inherited component from the full view of the parent, if any. ! 2001-12-12 Robert Dewar * checks.ads (Apply_Alignment_Check): New procedure. ! ! * exp_ch13.adb (Expand_N_Freeze_Entity): Generate dynamic check to ! ensure that the alignment of objects with address clauses is appropriate, and raise PE if not. ! * exp_util.ads (Must_Be_Aligned): Removed, replaced by Exp_Pakd.Known_Aligned_Enough ! * mdllfile.ads: Minor reformatting * mlib-fil.ads: Minor reformatting ! 2001-12-12 Ed Schonberg ! * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Extend previous ! fix to any component reference if enclosing record has non-standard representation. ! 2001-12-12 Vincent Celier ! * g-dirope.ads (Find, Wildcard_Iterator): Moved to child package Iteration ! 2001-12-12 Ed Schonberg ! * freeze.ads: Make Freeze_Fixed_Point_Type visible, for use in sem_attr. ! 2001-12-12 Robert Dewar * impunit.adb: Add entry for GNAT.Directory_Operations.Iteration ! 2001-12-12 Emmanuel Briot * g-regexp.adb: Remove all debug code, since it isn't required anymore, and it adds dependencies to system.io. ! 2001-12-12 Pascal Obry ! * g-dirope.adb (Expand_Path.Var): Correctly detect end of variable name. 2001-12-11 Ed Schonberg * sem_ch10.adb (Install_Withed_Unit): If the unit is a generic instance ! that is the parent of other generics, the instance body replaces the ! instance node. Retrieve the instance of the spec, which is the one that is visible in clients and within the body. 2001-12-11 Vincent Celier * gnatmain.adb: Initial version. ! * gnatmain.ads: Initial version. ! * prj-attr.adb (Initialisation_Data): Add package Gnatstub. ! * snames.adb: Updated to match snames.ads. ! * snames.ads: Added Gnatstub. ! 2001-12-11 Vincent Celier ! * prj-attr.adb (Initialization_Data): Change name from Initialisation_Data. ! 2001-12-11 Emmanuel Briot * g-regpat.adb (Parse_Literal): Properly handle simple operators ?, + and * applied to backslashed expressions like \r. ! 2001-12-11 Vasiliy Fofanov ! * g-os_lib.ads: String_List type added, Argument_List type is now subtype of String_List. ! 2001-12-11 Robert Dewar * g-os_lib.ads: Change copyright to FSF Add comments for String_List type ! 2001-12-11 Vincent Celier ! * g-dirope.adb (Expand_Path): Fix bug. (wrong length when adding a string to the buffer). 2001-12-11 Ed Schonberg * freeze.adb: Make Freeze_Fixed_Point_Type visible, for use in sem_attr. ! * sem_attr.adb: Simplify previous fix for Address. ! (Set_Bounds): If prefix is a non-frozen fixed-point type, freeze now, ! to avoid anomalies where the bound of the type appears to raise constraint error. 2001-12-11 Robert Dewar ! * lib-xref.adb (Output_Refs): Make sure pointers are always properly handled. ! 2001-12-11 Ed Schonberg ! * sem_ch12.adb (Analyze_Subprogram_Instantiation): Check for a renamed unit before checking for recursive instantiations. ! 2001-12-11 Emmanuel Briot * prj.ads: Add comments for some of the fields. 2001-12-11 Robert Dewar ! * lib-xref.adb (Output_Refs): Don't output type references outside the main unit if they are not otherwise referenced. ! 2001-12-11 Ed Schonberg ! * sem_attr.adb (Analyze_attribute, case Address and Size): Simplify code and diagnose additional illegal uses ! ! * sem_util.adb (Is_Object_Reference): An indexed component is an object only if the prefix is. ! 2001-12-11 Vincent Celier * g-diopit.adb: Initial version. ! * g-diopit.ads: Initial version. ! * g-dirope.adb: (Expand_Path): Avoid use of Unbounded_String (Find, Wildcard_Iterator): Moved to child package Iteration ! * Makefile.in: Added g-diopit.o to GNATRTL_NONTASKING_OBJS ! 2001-12-11 Robert Dewar * sem_attr.adb: Minor reformatting --- 1598,1775 ---- 2001-12-12 Ed Schonberg ! * sem_ch12.adb (Save_Entity_Descendant): Use syntactic field names on known node types, rather than untyped fields. Further cleanups. ! 2001-12-12 Robert Dewar * sem_ch12.adb: (Save_Entity_Descendant): Minor comment update. (Copy_Generic_Node): Deal with incorrect reference to Associated_Node ! of an N_Attribute_Reference node. As per note below, this does not eliminate need for Associated_Node in attribute ref nodes. ! (Associated_Node): Documentation explicitly mentions attribute reference nodes, since this field is used in such nodes. ! * sem_ch12.adb (Associated_Node): Minor documentation cleanup. 2001-12-12 Robert Dewar * s-stalib.adb: Add more comments on with statements being needed ! * par-ch12.adb: Minor reformatting ! * prj-dect.ads: Fix copyright header ! ! * s-arit64.adb (Multiply_With_Ovflo_Check): Fix case where both inputs fit in 32 bits, but the result still overflows. ! * s-fatgen.ads: Minor comment improvement ! 2001-12-12 Ed Schonberg ! * sem_ch4.adb (Analyze_Selected_Component): If the prefix is of a ! formal derived type, look for an inherited component from the full view of the parent, if any. ! 2001-12-12 Robert Dewar * checks.ads (Apply_Alignment_Check): New procedure. ! ! * exp_ch13.adb (Expand_N_Freeze_Entity): Generate dynamic check to ! ensure that the alignment of objects with address clauses is appropriate, and raise PE if not. ! * exp_util.ads (Must_Be_Aligned): Removed, replaced by Exp_Pakd.Known_Aligned_Enough ! * mdllfile.ads: Minor reformatting * mlib-fil.ads: Minor reformatting ! 2001-12-12 Ed Schonberg ! * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Extend previous ! fix to any component reference if enclosing record has non-standard representation. ! 2001-12-12 Vincent Celier ! * g-dirope.ads (Find, Wildcard_Iterator): Moved to child package Iteration ! 2001-12-12 Ed Schonberg ! * freeze.ads: Make Freeze_Fixed_Point_Type visible, for use in sem_attr. ! 2001-12-12 Robert Dewar * impunit.adb: Add entry for GNAT.Directory_Operations.Iteration ! 2001-12-12 Emmanuel Briot * g-regexp.adb: Remove all debug code, since it isn't required anymore, and it adds dependencies to system.io. ! 2001-12-12 Pascal Obry ! * g-dirope.adb (Expand_Path.Var): Correctly detect end of variable name. 2001-12-11 Ed Schonberg * sem_ch10.adb (Install_Withed_Unit): If the unit is a generic instance ! that is the parent of other generics, the instance body replaces the ! instance node. Retrieve the instance of the spec, which is the one that is visible in clients and within the body. 2001-12-11 Vincent Celier * gnatmain.adb: Initial version. ! * gnatmain.ads: Initial version. ! * prj-attr.adb (Initialisation_Data): Add package Gnatstub. ! * snames.adb: Updated to match snames.ads. ! * snames.ads: Added Gnatstub. ! 2001-12-11 Vincent Celier ! * prj-attr.adb (Initialization_Data): Change name from Initialisation_Data. ! 2001-12-11 Emmanuel Briot * g-regpat.adb (Parse_Literal): Properly handle simple operators ?, + and * applied to backslashed expressions like \r. ! 2001-12-11 Vasiliy Fofanov ! * g-os_lib.ads: String_List type added, Argument_List type is now subtype of String_List. ! 2001-12-11 Robert Dewar * g-os_lib.ads: Change copyright to FSF Add comments for String_List type ! 2001-12-11 Vincent Celier ! * g-dirope.adb (Expand_Path): Fix bug. (wrong length when adding a string to the buffer). 2001-12-11 Ed Schonberg * freeze.adb: Make Freeze_Fixed_Point_Type visible, for use in sem_attr. ! * sem_attr.adb: Simplify previous fix for Address. ! (Set_Bounds): If prefix is a non-frozen fixed-point type, freeze now, ! to avoid anomalies where the bound of the type appears to raise constraint error. 2001-12-11 Robert Dewar ! * lib-xref.adb (Output_Refs): Make sure pointers are always properly handled. ! 2001-12-11 Ed Schonberg ! * sem_ch12.adb (Analyze_Subprogram_Instantiation): Check for a renamed unit before checking for recursive instantiations. ! 2001-12-11 Emmanuel Briot * prj.ads: Add comments for some of the fields. 2001-12-11 Robert Dewar ! * lib-xref.adb (Output_Refs): Don't output type references outside the main unit if they are not otherwise referenced. ! 2001-12-11 Ed Schonberg ! * sem_attr.adb (Analyze_attribute, case Address and Size): Simplify code and diagnose additional illegal uses ! ! * sem_util.adb (Is_Object_Reference): An indexed component is an object only if the prefix is. ! 2001-12-11 Vincent Celier * g-diopit.adb: Initial version. ! * g-diopit.ads: Initial version. ! * g-dirope.adb: (Expand_Path): Avoid use of Unbounded_String (Find, Wildcard_Iterator): Moved to child package Iteration ! * Makefile.in: Added g-diopit.o to GNATRTL_NONTASKING_OBJS ! 2001-12-11 Robert Dewar * sem_attr.adb: Minor reformatting *************** *** 1265,1307 **** 2001-12-11 Ed Schonberg * sem_ch3.adb: Clarify some ???. ! 2001-12-11 Robert Dewar ! * exp_util.adb (Must_Be_Aligned): Removed, replaced by Exp_Pakd.Known_Aligned_Enough ! ! * sem_ch13.adb (Check_Address_Alignment): Removed, extended version is moved to Exp_Ch13. 2001-12-11 Robert Dewar * einfo.ads: Minor reformatting ! * exp_ch5.adb: Add comment for previous.change ! * ali.adb: New interface for extended typeref stuff. ! * ali.ads: New interface for typeref stuff. ! * checks.adb (Apply_Alignment_Check): New procedure. ! * debug.adb: Add -gnatdM for modified ALI output ! * exp_pakd.adb (Known_Aligned_Enough): Replaces Known_Aligned_Enough. ! ! * lib-xref.adb: Extend generation of <..> notation to cover ! subtype/object types. Note that this is a complete rewrite, ! getting rid of the very nasty quadratic algorithm previously used for derived type output. ! ! * lib-xref.ads: Extend description of <..> notation to cover ! subtype/object types. Uses {..} for these other cases. Also use (..) for pointer types. ! * sem_util.adb (Check_Potentially_Blocking_Operation): Slight cleanup. ! ! * exp_pakd.adb: Minor reformatting. Note that prevous RH should say: (Known_Aligned_Enough): Replaces Must_Be_Aligned. 2001-12-11 Vincent Celier --- 1777,1819 ---- 2001-12-11 Ed Schonberg * sem_ch3.adb: Clarify some ???. ! 2001-12-11 Robert Dewar ! * exp_util.adb (Must_Be_Aligned): Removed, replaced by Exp_Pakd.Known_Aligned_Enough ! ! * sem_ch13.adb (Check_Address_Alignment): Removed, extended version is moved to Exp_Ch13. 2001-12-11 Robert Dewar * einfo.ads: Minor reformatting ! * exp_ch5.adb: Add comment for previous.change ! * ali.adb: New interface for extended typeref stuff. ! * ali.ads: New interface for typeref stuff. ! * checks.adb (Apply_Alignment_Check): New procedure. ! * debug.adb: Add -gnatdM for modified ALI output ! * exp_pakd.adb (Known_Aligned_Enough): Replaces Known_Aligned_Enough. ! ! * lib-xref.adb: Extend generation of <..> notation to cover ! subtype/object types. Note that this is a complete rewrite, ! getting rid of the very nasty quadratic algorithm previously used for derived type output. ! ! * lib-xref.ads: Extend description of <..> notation to cover ! subtype/object types. Uses {..} for these other cases. Also use (..) for pointer types. ! * sem_util.adb (Check_Potentially_Blocking_Operation): Slight cleanup. ! ! * exp_pakd.adb: Minor reformatting. Note that prevous RH should say: (Known_Aligned_Enough): Replaces Must_Be_Aligned. 2001-12-11 Vincent Celier *************** *** 1310,1354 **** Changed /COMPILE_ONLY to /ACTIONS=COMPILE Changed /BIND_ONLY to /ACTIONS=BIND Changed /LINK_ONLY to /ACTIONS=LINK ! 2001-12-11 Ed Schonberg * sem_ch8.adb (Find_Selected_Component): improved search for a candidate package in case of error. ! * sem_ch12.adb (Inline_Instance_Body): place head of use_clause chain back on scope stack before reinstalling use clauses. ! * exp_ch5.adb (Expand_N_If_Statement): if Constant_Condition_Warnings is enabled, do not kill the code for the condition, to preserve warning. 2001-12-11 Robert Dewar ! * checks.adb (Insert_Valid_Check): Apply validity check to expression of conversion, not to result of conversion. 2001-12-11 Ed Schonberg ! ! * sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag ! before freezing parent. If the declarations are mutually recursive, ! an access to the current record type may be frozen before the derivation is complete. 2001-12-05 Vincent Celier ! * gnatcmd.adb: (MAKE): Add new translations: -b /BIND_ONLY, -c /COMPILE_ONLY, -l /LINK_ONLY ! * opt.ads: (Bind_Only): New Flag (Link_Only): New flag ! ! * switch.adb (Scan_Make_Switches): Add processing for -b (Bind_Only) and -l (Link_Only) ! * makeusg.adb: Add new switches -b and -l. Update Copyright notice. ! * make.adb: (Do_Compile_Step, Do_Bind_Step, Do_Link_Step): New flags. (Gnatmake): Set the step flags. Only perform a step if the --- 1822,1866 ---- Changed /COMPILE_ONLY to /ACTIONS=COMPILE Changed /BIND_ONLY to /ACTIONS=BIND Changed /LINK_ONLY to /ACTIONS=LINK ! 2001-12-11 Ed Schonberg * sem_ch8.adb (Find_Selected_Component): improved search for a candidate package in case of error. ! * sem_ch12.adb (Inline_Instance_Body): place head of use_clause chain back on scope stack before reinstalling use clauses. ! * exp_ch5.adb (Expand_N_If_Statement): if Constant_Condition_Warnings is enabled, do not kill the code for the condition, to preserve warning. 2001-12-11 Robert Dewar ! * checks.adb (Insert_Valid_Check): Apply validity check to expression of conversion, not to result of conversion. 2001-12-11 Ed Schonberg ! ! * sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag ! before freezing parent. If the declarations are mutually recursive, ! an access to the current record type may be frozen before the derivation is complete. 2001-12-05 Vincent Celier ! * gnatcmd.adb: (MAKE): Add new translations: -b /BIND_ONLY, -c /COMPILE_ONLY, -l /LINK_ONLY ! * opt.ads: (Bind_Only): New Flag (Link_Only): New flag ! ! * switch.adb (Scan_Make_Switches): Add processing for -b (Bind_Only) and -l (Link_Only) ! * makeusg.adb: Add new switches -b and -l. Update Copyright notice. ! * make.adb: (Do_Compile_Step, Do_Bind_Step, Do_Link_Step): New flags. (Gnatmake): Set the step flags. Only perform a step if the *************** *** 1358,1385 **** 2001-12-05 Ed Schonberg ! * sem_eval.adb (Eval_Concatenation): If left operand is a null string, get bounds from right operand. ! * sem_eval.adb: Minor reformatting ! ! * exp_util.adb (Make_Literal_Range): use bound of literal rather than Index'First, its lower bound may be different from 1. ! ! * exp_util.adb: Undo earlier change, fixes ACVC regressions C48009B and C48009J ! 2001-12-05 Vincent Celier * prj-nmsc.adb Minor reformatting ! ! * prj-nmsc.adb (Language_Independent_Check): Reset Library flag if set and libraries are not supported. ! 2001-12-05 Ed Schonberg ! * sem_ch3.adb (Build_Derived_Private_Type): set Public status of ! private view explicitly, so the back-end can treat as a global when appropriate. 2001-12-05 Ed Schonberg --- 1870,1897 ---- 2001-12-05 Ed Schonberg ! * sem_eval.adb (Eval_Concatenation): If left operand is a null string, get bounds from right operand. ! * sem_eval.adb: Minor reformatting ! ! * exp_util.adb (Make_Literal_Range): use bound of literal rather than Index'First, its lower bound may be different from 1. ! ! * exp_util.adb: Undo earlier change, fixes ACVC regressions C48009B and C48009J ! 2001-12-05 Vincent Celier * prj-nmsc.adb Minor reformatting ! ! * prj-nmsc.adb (Language_Independent_Check): Reset Library flag if set and libraries are not supported. ! 2001-12-05 Ed Schonberg ! * sem_ch3.adb (Build_Derived_Private_Type): set Public status of ! private view explicitly, so the back-end can treat as a global when appropriate. 2001-12-05 Ed Schonberg *************** *** 1388,1404 **** unit, always replace instance node with new body, for ASIS use. 2001-12-05 Vincent Celier ! ! * prj-nmsc.adb (Language_Independent_Check): Issue a warning if ! libraries are not supported and both attributes Library_Name and Library_Dir are specified. ! ! * prj-proc.adb (Expression): Set location of Result to location of first term. ! * Makefile.in: Add mlib.o, mlib-fil.o, mlib-tgt and mlib-utl to GNATLS. (prj-nmsc is now importing MLib.Tgt) ! * prj-proc.adb: Put the change indicated above that was forgotten. 2001-12-05 Robert Dewar --- 1900,1916 ---- unit, always replace instance node with new body, for ASIS use. 2001-12-05 Vincent Celier ! ! * prj-nmsc.adb (Language_Independent_Check): Issue a warning if ! libraries are not supported and both attributes Library_Name and Library_Dir are specified. ! ! * prj-proc.adb (Expression): Set location of Result to location of first term. ! * Makefile.in: Add mlib.o, mlib-fil.o, mlib-tgt and mlib-utl to GNATLS. (prj-nmsc is now importing MLib.Tgt) ! * prj-proc.adb: Put the change indicated above that was forgotten. 2001-12-05 Robert Dewar *************** *** 1409,1442 **** * sem_ch3.adb (Build_Derived_Concurrent_Type): If derivation imposes a constraint, introduce explicit subtype declaration and derive from it. ! * sem_ch3.adb: Minor reformatting 2001-12-05 Robert Dewar ! * checks.adb (Determine_Range): Increase cache size for checks. Minor reformatting ! * exp_ch6.adb: Minor reformatting (Expand_N_Subprogram_Body): Reset Is_Pure for any subprogram that has a parameter whose root type is System.Address, since treating such subprograms as pure in the code generator is almost surely a mistake that will lead to unexpected results. ! ! * exp_util.adb (Remove_Side_Effects): Clean up old ??? comment and change handling of conversions. ! * g-regexp.adb: Use System.IO instead of Ada.Text_IO. 2001-12-05 Ed Schonberg ! * sem_ch3.adb (Analyze_Object_Declaration): If expression is an ! aggregate with static wrong size, attach generated Raise node to declaration. 2001-12-05 Robert Dewar ! * sem_attr.adb (Analyze_Attribute): Defend against bad Val attribute. Fixes compilation abandoned bomb in B24009B. 2001-12-05 Ed Schonberg --- 1921,1954 ---- * sem_ch3.adb (Build_Derived_Concurrent_Type): If derivation imposes a constraint, introduce explicit subtype declaration and derive from it. ! * sem_ch3.adb: Minor reformatting 2001-12-05 Robert Dewar ! * checks.adb (Determine_Range): Increase cache size for checks. Minor reformatting ! * exp_ch6.adb: Minor reformatting (Expand_N_Subprogram_Body): Reset Is_Pure for any subprogram that has a parameter whose root type is System.Address, since treating such subprograms as pure in the code generator is almost surely a mistake that will lead to unexpected results. ! ! * exp_util.adb (Remove_Side_Effects): Clean up old ??? comment and change handling of conversions. ! * g-regexp.adb: Use System.IO instead of Ada.Text_IO. 2001-12-05 Ed Schonberg ! * sem_ch3.adb (Analyze_Object_Declaration): If expression is an ! aggregate with static wrong size, attach generated Raise node to declaration. 2001-12-05 Robert Dewar ! * sem_attr.adb (Analyze_Attribute): Defend against bad Val attribute. Fixes compilation abandoned bomb in B24009B. 2001-12-05 Ed Schonberg *************** *** 1450,1460 **** * prj-dect.ads: Add ??? comment Add 2001 to copyright notice (was not done in after all) ! * prj-part.adb: Minor reformatting. Reword one awkward error message. ! * prj.ads: Minor reformatting throughout, and add some ??? comments ! * snames.ads: Minor reformatting 2001-12-05 Geert Bosch --- 1962,1972 ---- * prj-dect.ads: Add ??? comment Add 2001 to copyright notice (was not done in after all) ! * prj-part.adb: Minor reformatting. Reword one awkward error message. ! * prj.ads: Minor reformatting throughout, and add some ??? comments ! * snames.ads: Minor reformatting 2001-12-05 Geert Bosch *************** *** 1464,1493 **** 2001-12-05 Vincent Celier * prj-dect.adb (Parse): Rename parameter Modifying to Extends. ! * prj-dect.ads (Parse): Rename parameter Modifying to Extends. ! * prj-env.adb: Minor comment changes (modifying -> extends). ! * prj-nmsc.adb: Minor comment changes (modifying -> extends). ! ! * prj-part.adb (Parse_Single_Project): Change Tok_Modifying to Tok_Extends. ! * prj.adb (Initialize): Change Modifying to Extends. ! * scans.ads (Token_Type): Change Tok_Modifying to Tok_Extends. ! * prj.ads: Minor comment change (Modifying -> extending). ! * snames.ads: Change modifying to extends. 2001-12-05 Robert Dewar ! * sem_warn.adb: Remove stuff for conditionals, we are not going to do this after all. ! ! * sem_warn.ads: Remove stuff for conditionals, we are not going to do this after all. Add 2001 to copyright notice 2001-12-04 Geert Bosch --- 1976,2005 ---- 2001-12-05 Vincent Celier * prj-dect.adb (Parse): Rename parameter Modifying to Extends. ! * prj-dect.ads (Parse): Rename parameter Modifying to Extends. ! * prj-env.adb: Minor comment changes (modifying -> extends). ! * prj-nmsc.adb: Minor comment changes (modifying -> extends). ! ! * prj-part.adb (Parse_Single_Project): Change Tok_Modifying to Tok_Extends. ! * prj.adb (Initialize): Change Modifying to Extends. ! * scans.ads (Token_Type): Change Tok_Modifying to Tok_Extends. ! * prj.ads: Minor comment change (Modifying -> extending). ! * snames.ads: Change modifying to extends. 2001-12-05 Robert Dewar ! * sem_warn.adb: Remove stuff for conditionals, we are not going to do this after all. ! ! * sem_warn.ads: Remove stuff for conditionals, we are not going to do this after all. Add 2001 to copyright notice 2001-12-04 Geert Bosch *************** *** 1496,1505 **** 2001-12-04 Robert Dewar ! * errout.adb (Error_Msg): Ignore attempt to put error msg at junk ! location if we already have errors. Stops some cases of cascaded errors. ! * errout.adb: Improve comment. 2001-12-04 Robert Dewar --- 2008,2017 ---- 2001-12-04 Robert Dewar ! * errout.adb (Error_Msg): Ignore attempt to put error msg at junk ! location if we already have errors. Stops some cases of cascaded errors. ! * errout.adb: Improve comment. 2001-12-04 Robert Dewar *************** *** 1507,1514 **** * sem_ch12.adb: (Analyze_Formal_Type_Definition): Defend against Error. (Analyze_Formal_Subprogram): Defend against Error. ! ! * par-ch12.adb (F_Formal_Type_Declaration): In case of error, remove following semicolon if present. Removes cascaded error. 2001-12-04 Douglas B. Rupp --- 2019,2026 ---- * sem_ch12.adb: (Analyze_Formal_Type_Definition): Defend against Error. (Analyze_Formal_Subprogram): Defend against Error. ! ! * par-ch12.adb (F_Formal_Type_Declaration): In case of error, remove following semicolon if present. Removes cascaded error. 2001-12-04 Douglas B. Rupp *************** *** 1525,1546 **** 2001-12-04 Ed Schonberg ! * einfo.ads: Block_Node points to the identifier of the block, not to ! the block node itself, to preserve the link when the block is ! rewritten, e.g. within an if-statement with a static condition. ! ! * inline.adb (Cleanup_Scopes): recover block statement from block entity using new meaning of Block_Node. ! ! * sem_ch5.adb (Analyze_Block_Statement): set Block_Node to point to identifier of block node, rather than to node itself. 2001-12-04 Gary Dismukes ! * layout.adb: (Get_Max_Size): Fix "start of processing" comment to say Get_Max_Size. (Discrimify): Go back to setting the Etypes of the selected component ! because the Vname component does not exist at this point and will fail name resolution. Also set Analyzed. Remove with and use of Sem_Res. --- 2037,2058 ---- 2001-12-04 Ed Schonberg ! * einfo.ads: Block_Node points to the identifier of the block, not to ! the block node itself, to preserve the link when the block is ! rewritten, e.g. within an if-statement with a static condition. ! ! * inline.adb (Cleanup_Scopes): recover block statement from block entity using new meaning of Block_Node. ! ! * sem_ch5.adb (Analyze_Block_Statement): set Block_Node to point to identifier of block node, rather than to node itself. 2001-12-04 Gary Dismukes ! * layout.adb: (Get_Max_Size): Fix "start of processing" comment to say Get_Max_Size. (Discrimify): Go back to setting the Etypes of the selected component ! because the Vname component does not exist at this point and will fail name resolution. Also set Analyzed. Remove with and use of Sem_Res. *************** *** 1557,1584 **** 2001-12-04 Ed Schonberg ! * sem_ch7.adb (New_Private_Type): Set Is_Tagged_Type flag before processing discriminants to diagnose illegal default values. 2001-12-04 Ed Schonberg ! * sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide ! access discriminant within a type extension that constrains its parent discriminants. 2001-12-04 Ed Schonberg ! * sem_ch3.adb (Find_Type_Of_Subtype_Indic): If subtype indication is malformed, use instance of Any_Id to allow analysis to proceed. ! ! * par-ch12.adb (P_Formal_Type_Declaration): Propagate Error if type definition is illegal. (P_Formal_Derived_Type_Definition): Better recovery when TAGGED is misplaced. 2001-12-04 Ed Schonberg ! * sem_warn.adb (Output_Unreferenced_Messages): Extend previous fix to constants. 2001-12-04 Robert Dewar --- 2069,2096 ---- 2001-12-04 Ed Schonberg ! * sem_ch7.adb (New_Private_Type): Set Is_Tagged_Type flag before processing discriminants to diagnose illegal default values. 2001-12-04 Ed Schonberg ! * sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide ! access discriminant within a type extension that constrains its parent discriminants. 2001-12-04 Ed Schonberg ! * sem_ch3.adb (Find_Type_Of_Subtype_Indic): If subtype indication is malformed, use instance of Any_Id to allow analysis to proceed. ! ! * par-ch12.adb (P_Formal_Type_Declaration): Propagate Error if type definition is illegal. (P_Formal_Derived_Type_Definition): Better recovery when TAGGED is misplaced. 2001-12-04 Ed Schonberg ! * sem_warn.adb (Output_Unreferenced_Messages): Extend previous fix to constants. 2001-12-04 Robert Dewar *************** *** 1588,1601 **** 2001-12-04 Robert Dewar * exp_util.adb: Minor reformatting from last change ! ! * errout.adb (Check_For_Warning): For a Raised_Constraint_Error node ! which is a rewriting of an expression, traverse the original expression to remove warnings that may have been posted on it. 2001-12-04 Ed Schonberg ! * exp_util.adb (Must_Be_Aligned): Return false for a component of a record that has other packed components. 2001-12-04 Douglass B. Rupp --- 2100,2113 ---- 2001-12-04 Robert Dewar * exp_util.adb: Minor reformatting from last change ! ! * errout.adb (Check_For_Warning): For a Raised_Constraint_Error node ! which is a rewriting of an expression, traverse the original expression to remove warnings that may have been posted on it. 2001-12-04 Ed Schonberg ! * exp_util.adb (Must_Be_Aligned): Return false for a component of a record that has other packed components. 2001-12-04 Douglass B. Rupp *************** *** 1608,1614 **** 2001-12-04 Arnaud Charlet ! * Makefile.adalib: Clarify step 3 (use of gnat.adc) as it causes more confusion than it solves. 2001-12-04 Geert bosch --- 2120,2126 ---- 2001-12-04 Arnaud Charlet ! * Makefile.adalib: Clarify step 3 (use of gnat.adc) as it causes more confusion than it solves. 2001-12-04 Geert bosch *************** *** 1617,1628 **** 2001-12-04 Geert Bosch ! * Makefile.in (update-sources): New target. For use by gcc_release script. 2001-12-04 Ed Schonberg ! * sem_prag.adb (Analyze_Pragma, case Validity_Checks): do not treat as a configuration pragma, it is now legal wherever a pragma can appear. 2001-12-04 Zack Weinberg --- 2129,2140 ---- 2001-12-04 Geert Bosch ! * Makefile.in (update-sources): New target. For use by gcc_release script. 2001-12-04 Ed Schonberg ! * sem_prag.adb (Analyze_Pragma, case Validity_Checks): do not treat as a configuration pragma, it is now legal wherever a pragma can appear. 2001-12-04 Zack Weinberg *************** *** 1635,1643 **** * einfo.adb (Has_Pragma_Pure_Function): New flag. Fix problem that stopped ceinfo from working ! * einfo.ads (Has_Pragma_Pure_Function): New flag. ! * sem_prag.adb (Pure_Function): Set new flag Has_Pragma_Pure_Function. 2001-12-04 Douglas B. Rupp --- 2147,2155 ---- * einfo.adb (Has_Pragma_Pure_Function): New flag. Fix problem that stopped ceinfo from working ! * einfo.ads (Has_Pragma_Pure_Function): New flag. ! * sem_prag.adb (Pure_Function): Set new flag Has_Pragma_Pure_Function. 2001-12-04 Douglas B. Rupp *************** *** 1647,1667 **** (Preserve_Mode): New boolean. (Write_Unit): Pass time stamp. Implement -p switch (preserve time stamps). ! * gnatcmd.adb (CHOP): Add translation for -p (/PRESERVE). ! * gnatchop.adb: Do usage info for -p switch ! * adaint.h (__gnat_set_file_time_name): New function ! * adaint.c (__gnat_set_file_time_name): Implement ! * adaint.h: Fix typo 2001-12-03 Robert Dewar * sinfo.ads: Minor reformatting. N_Freeze_Entity node does not ! have Associated_Node. 2001-12-03 Robert Dewar --- 2159,2179 ---- (Preserve_Mode): New boolean. (Write_Unit): Pass time stamp. Implement -p switch (preserve time stamps). ! * gnatcmd.adb (CHOP): Add translation for -p (/PRESERVE). ! * gnatchop.adb: Do usage info for -p switch ! * adaint.h (__gnat_set_file_time_name): New function ! * adaint.c (__gnat_set_file_time_name): Implement ! * adaint.h: Fix typo 2001-12-03 Robert Dewar * sinfo.ads: Minor reformatting. N_Freeze_Entity node does not ! have Associated_Node. 2001-12-03 Robert Dewar *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 2034,2040 **** 2001-10-26 Vincent Celier * g-os_lib.adb (Normalize_Pathname): Preserve the double slash ! ("//") that precede the drive letter on Interix. 2001-10-26 Geert Bosch --- 2546,2552 ---- 2001-10-26 Vincent Celier * g-os_lib.adb (Normalize_Pathname): Preserve the double slash ! ("//") that precede the drive letter on Interix. 2001-10-26 Geert Bosch *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 2043,2049 **** 2001-10-25 Robert Dewar * sem_ch8.adb (Analyze_Package_Renaming): Skip analysis if Name ! is Error. Similar change for other renaming cases. 2001-10-25 Robert Dewar --- 2555,2561 ---- 2001-10-25 Robert Dewar * sem_ch8.adb (Analyze_Package_Renaming): Skip analysis if Name ! is Error. Similar change for other renaming cases. 2001-10-25 Robert Dewar *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 2053,2074 **** 2001-10-25 Ed Schonberg * par-ch3.adb (P_Subtype_Mark_Resync): for an anonymous array ! return Error rather than Empty so that analysis can proceed. 2001-10-25 Ed Schonberg * sem_util.adb (Enter_Name): better handling of cascaded error ! messages when a unit appears in its own context. 2001-10-25 Ed Schonberg * sem_util.adb (Defining_Entity): in case of error, attach created ! entity to specification, so that semantic analysis can proceed. 2001-10-25 Robert Dewar * sem_util.adb ! (Defining_Entity): Deal with Error. (Process_End_Label): Deal with bad end label for. 2001-10-25 Ed Schonberg --- 2565,2586 ---- 2001-10-25 Ed Schonberg * par-ch3.adb (P_Subtype_Mark_Resync): for an anonymous array ! return Error rather than Empty so that analysis can proceed. 2001-10-25 Ed Schonberg * sem_util.adb (Enter_Name): better handling of cascaded error ! messages when a unit appears in its own context. 2001-10-25 Ed Schonberg * sem_util.adb (Defining_Entity): in case of error, attach created ! entity to specification, so that semantic analysis can proceed. 2001-10-25 Robert Dewar * sem_util.adb ! (Defining_Entity): Deal with Error. (Process_End_Label): Deal with bad end label for. 2001-10-25 Ed Schonberg *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 2088,2107 **** 2001-10-25 Ed Schonberg * sem_res.adb (Resolve_Call): if the call is actually an indexing ! operation on the result of a parameterless call, perform elaboration ! check after the node has been properly rewritten. * sem_ch12.adb (Copy_Generic_Node): after the proper body has been ! inlined within the generic tree, the defining identifier is not a ! compilation_unit. 2001-10-25 Ed Schonberg * sem_res.adb (Resolve): special-case resolution of Null in an ! instance or an inlined body to avoid view conflicts. * sem_ch12.adb (Copy_Generic_Node): for allocators, check for view ! compatibility by retrieving the access type of the generic copy. 2001-10-25 Robert Dewar --- 2600,2619 ---- 2001-10-25 Ed Schonberg * sem_res.adb (Resolve_Call): if the call is actually an indexing ! operation on the result of a parameterless call, perform elaboration ! check after the node has been properly rewritten. * sem_ch12.adb (Copy_Generic_Node): after the proper body has been ! inlined within the generic tree, the defining identifier is not a ! compilation_unit. 2001-10-25 Ed Schonberg * sem_res.adb (Resolve): special-case resolution of Null in an ! instance or an inlined body to avoid view conflicts. * sem_ch12.adb (Copy_Generic_Node): for allocators, check for view ! compatibility by retrieving the access type of the generic copy. 2001-10-25 Robert Dewar *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 2120,2129 **** 2001-10-25 Pascal Obry * gnatmem.adb (Read_Next): fix Curs2 value to properly handle quiet ! mode case for ALLOC case. * gnatmem.adb (Read_Next): correctly fix parsing in Quiet mode on ! all platforms. Improvement of last change. 2001-10-25 Robert Dewar --- 2632,2641 ---- 2001-10-25 Pascal Obry * gnatmem.adb (Read_Next): fix Curs2 value to properly handle quiet ! mode case for ALLOC case. * gnatmem.adb (Read_Next): correctly fix parsing in Quiet mode on ! all platforms. Improvement of last change. 2001-10-25 Robert Dewar *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 2136,2160 **** 2001-10-25 Pascal Obry * osint.adb (Read_Default_Search_Dirs): correctly detect relative ! pathnames in UNIX and DOS style with drive letter. (Is_Relative): new routine. * osint.adb: Minor reformatting * osint.adb (Is_Relative): implementation using ! GNAT.OS_Lib.Is_Absolute_Path. Better fix. 2001-10-25 Pascal Obry * g-dirope.adb (Basename): correctly compute offset between the ! original Path and the translated one. * g-dirope.adb: (Base_Name): add some comments. 2001-10-25 Robert Dewar * exp_imgv.adb (Expand_Image_Attribute): Defend against bad use ! in HIE mode, avoids compilation abandoned message * exp_imgv.adb: Correct typo in previous change --- 2648,2672 ---- 2001-10-25 Pascal Obry * osint.adb (Read_Default_Search_Dirs): correctly detect relative ! pathnames in UNIX and DOS style with drive letter. (Is_Relative): new routine. * osint.adb: Minor reformatting * osint.adb (Is_Relative): implementation using ! GNAT.OS_Lib.Is_Absolute_Path. Better fix. 2001-10-25 Pascal Obry * g-dirope.adb (Basename): correctly compute offset between the ! original Path and the translated one. * g-dirope.adb: (Base_Name): add some comments. 2001-10-25 Robert Dewar * exp_imgv.adb (Expand_Image_Attribute): Defend against bad use ! in HIE mode, avoids compilation abandoned message * exp_imgv.adb: Correct typo in previous change *************** Thu Nov 15 18:16:17 2001 Richard Kenner *** 2764,2777 **** 2001-10-02 Geert Bosch * misc.c (insert_default_attributes): Add dummy version. - 2003-01-27 Christian Cornelssen - - * Make-lang.in (ada.install-common): Let $(DESTDIR)$(bindir) - be created if necessary. Remove erroneous and redundant - gnatchop installation commands. Test for gnatdll before - attempting to install it. Use initial tab instead of spaces - in continuation lines. - (ada.uninstall): Uninstall gnat instead of gnatcmd. - Also uninstall gnatfind, gnatxref, gnatlbr, and gnatdll - from all plausible locations. - --- 3276,3278 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/checks.adb gcc-3.3/gcc/ada/checks.adb *** gcc-3.2.3/gcc/ada/checks.adb 2002-05-04 03:27:35.000000000 +0000 --- gcc-3.3/gcc/ada/checks.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.6.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Sem_Warn; use Sem_Warn; *** 47,52 **** --- 46,52 ---- with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; + with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Urealp; use Urealp; *************** package body Checks is *** 197,203 **** else Append_To ! (Stmts, Make_Raise_Constraint_Error (Internal_Static_Sloc)); end if; end loop; end Append_Range_Checks; --- 197,205 ---- else Append_To ! (Stmts, ! Make_Raise_Constraint_Error (Internal_Static_Sloc, ! Reason => CE_Range_Check_Failed)); end if; end loop; end Append_Range_Checks; *************** package body Checks is *** 272,278 **** Condition => Make_Op_Gt (Loc, Left_Opnd => Param_Level, ! Right_Opnd => Type_Level))); Analyze_And_Resolve (N); end if; --- 274,281 ---- Condition => Make_Op_Gt (Loc, Left_Opnd => Param_Level, ! Right_Opnd => Type_Level), ! Reason => PE_Accessibility_Check_Failed)); Analyze_And_Resolve (N); end if; *************** package body Checks is *** 315,325 **** and then Known_Alignment (E) then if Expr_Value (Expr) mod Alignment (E) /= 0 then ! Insert_Action (N, ! Make_Raise_Program_Error (Loc)); ! Error_Msg_NE ! ("?specified address for& not " & ! "consistent with alignment", Expr, E); end if; -- Here we do not know if the value is acceptable, generate --- 318,329 ---- and then Known_Alignment (E) then if Expr_Value (Expr) mod Alignment (E) /= 0 then ! Insert_Action (N, ! Make_Raise_Program_Error (Loc, ! Reason => PE_Misaligned_Address_Value)); ! Error_Msg_NE ! ("?specified address for& not " & ! "consistent with alignment", Expr, E); end if; -- Here we do not know if the value is acceptable, generate *************** package body Checks is *** 343,349 **** Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Alignment)), ! Right_Opnd => Make_Integer_Literal (Loc, Uint_0))), Suppress => All_Checks); end if; end if; --- 347,354 ---- Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Alignment)), ! Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), ! Reason => PE_Misaligned_Address_Value), Suppress => All_Checks); end if; end if; *************** package body Checks is *** 377,385 **** OK : Boolean; begin ! if not Software_Overflow_Checking ! or else not Do_Overflow_Check (N) ! or else not Expander_Active then return; end if; --- 382,390 ---- OK : Boolean; begin ! if Backend_Overflow_Checks_On_Target ! or not Do_Overflow_Check (N) ! or not Expander_Active then return; end if; *************** package body Checks is *** 682,688 **** if Static and then Siz >= Check_Siz then Insert_Action (N, ! Make_Raise_Storage_Error (Loc)); Warn_On_Instance := True; Error_Msg_N ("?Storage_Error will be raised at run-time", N); Warn_On_Instance := False; --- 687,694 ---- if Static and then Siz >= Check_Siz then Insert_Action (N, ! Make_Raise_Storage_Error (Loc, ! Reason => SE_Object_Too_Large)); Warn_On_Instance := True; Error_Msg_N ("?Storage_Error will be raised at run-time", N); Warn_On_Instance := False; *************** package body Checks is *** 739,749 **** Make_Op_Ge (Loc, Left_Opnd => Sizx, Right_Opnd => ! Make_Integer_Literal (Loc, Check_Siz))); Set_Size_Check_Code (Defining_Identifier (N), Code); Insert_Action (N, Code); - end Apply_Array_Size_Check; ---------------------------- --- 745,755 ---- Make_Op_Ge (Loc, Left_Opnd => Sizx, Right_Opnd => ! Make_Integer_Literal (Loc, Check_Siz)), ! Reason => SE_Object_Too_Large); Set_Size_Check_Code (Defining_Identifier (N), Code); Insert_Action (N, Code); end Apply_Array_Size_Check; ---------------------------- *************** package body Checks is *** 1026,1032 **** exit; else Apply_Compile_Time_Constraint_Error ! (N, "incorrect value for discriminant&?", Ent => Discr); return; end if; end if; --- 1032,1039 ---- exit; else Apply_Compile_Time_Constraint_Error ! (N, "incorrect value for discriminant&?", ! CE_Discriminant_Check_Failed, Ent => Discr); return; end if; end if; *************** package body Checks is *** 1070,1076 **** end if; Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, Condition => Cond)); end Apply_Discriminant_Check; --- 1077,1085 ---- end if; Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Discriminant_Check_Failed)); end Apply_Discriminant_Check; *************** package body Checks is *** 1094,1100 **** begin if Expander_Active ! and then Software_Overflow_Checking then Determine_Range (Right, ROK, Rlo, Rhi); --- 1103,1109 ---- begin if Expander_Active ! and not Backend_Divide_Checks_On_Target then Determine_Range (Right, ROK, Rlo, Rhi); *************** package body Checks is *** 1109,1115 **** Condition => Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Right), ! Right_Opnd => Make_Integer_Literal (Loc, 0)))); end if; end if; --- 1118,1125 ---- Condition => Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Right), ! Right_Opnd => Make_Integer_Literal (Loc, 0)), ! Reason => CE_Divide_By_Zero)); end if; end if; *************** package body Checks is *** 1139,1145 **** Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Right), Right_Opnd => ! Make_Integer_Literal (Loc, -1))))); end if; end if; end if; --- 1149,1156 ---- Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Right), Right_Opnd => ! Make_Integer_Literal (Loc, -1))), ! Reason => CE_Overflow_Check_Failed)); end if; end if; end if; *************** package body Checks is *** 1211,1217 **** procedure Bad_Value is begin Apply_Compile_Time_Constraint_Error ! (Expr, "value not in range of}?", Ent => Target_Typ, Typ => Target_Typ); end Bad_Value; --- 1222,1228 ---- procedure Bad_Value is begin Apply_Compile_Time_Constraint_Error ! (Expr, "value not in range of}?", CE_Range_Check_Failed, Ent => Target_Typ, Typ => Target_Typ); end Bad_Value; *************** package body Checks is *** 1439,1445 **** (not Length_Checks_Suppressed (Target_Typ)); begin ! if not Expander_Active or else not Checks_On then return; end if; --- 1450,1456 ---- (not Length_Checks_Suppressed (Target_Typ)); begin ! if not Expander_Active then return; end if; *************** package body Checks is *** 1478,1490 **** then Cond := Condition (R_Cno); ! if not Has_Dynamic_Length_Check (Ck_Node) then Insert_Action (Ck_Node, R_Cno); if not Do_Static then Set_Has_Dynamic_Length_Check (Ck_Node); end if; - end if; -- Output a warning if the condition is known to be True --- 1489,1502 ---- then Cond := Condition (R_Cno); ! if not Has_Dynamic_Length_Check (Ck_Node) ! and then Checks_On ! then Insert_Action (Ck_Node, R_Cno); if not Do_Static then Set_Has_Dynamic_Length_Check (Ck_Node); end if; end if; -- Output a warning if the condition is known to be True *************** package body Checks is *** 1494,1499 **** --- 1506,1512 ---- then Apply_Compile_Time_Constraint_Error (Ck_Node, "wrong length for array of}?", + CE_Length_Check_Failed, Ent => Target_Typ, Typ => Target_Typ); *************** package body Checks is *** 1576,1581 **** --- 1589,1595 ---- if Nkind (Ck_Node) = N_Range then Apply_Compile_Time_Constraint_Error (Low_Bound (Ck_Node), "static range out of bounds of}?", + CE_Range_Check_Failed, Ent => Target_Typ, Typ => Target_Typ); *************** package body Checks is *** 1584,1589 **** --- 1598,1604 ---- else Apply_Compile_Time_Constraint_Error (Ck_Node, "static value out of range of}?", + CE_Range_Check_Failed, Ent => Target_Typ, Typ => Target_Typ); end if; *************** package body Checks is *** 1661,1670 **** if Inside_A_Generic then return; ! -- Skip these checks if errors detected, there are some nasty -- situations of incomplete trees that blow things up. ! elsif Errors_Detected > 0 then return; -- Scalar type conversions of the form Target_Type (Expr) require --- 1676,1685 ---- if Inside_A_Generic then return; ! -- Skip these checks if serious errors detected, there are some nasty -- situations of incomplete trees that blow things up. ! elsif Serious_Errors_Detected > 0 then return; -- Scalar type conversions of the form Target_Type (Expr) require *************** package body Checks is *** 1778,1784 **** Set_Discriminant_Constraint (Expr_Type, Old_Constraints); Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, Condition => Cond)); end; -- should there be other checks here for array types ??? --- 1793,1801 ---- Set_Discriminant_Constraint (Expr_Type, Old_Constraints); Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Discriminant_Check_Failed)); end; -- should there be other checks here for array types ??? *************** package body Checks is *** 2774,2780 **** else Check_Node := ! Make_Raise_Constraint_Error (Internal_Static_Sloc); Mark_Rewrite_Insertion (Check_Node); if Do_Before then --- 2791,2798 ---- else Check_Node := ! Make_Raise_Constraint_Error (Internal_Static_Sloc, ! Reason => CE_Range_Check_Failed); Mark_Rewrite_Insertion (Check_Node); if Do_Before then *************** package body Checks is *** 2812,2818 **** Exp := Expression (Exp); end loop; ! -- insert the validity check. Note that we do this with validity -- checks turned off, to avoid recursion, we do not want validity -- checks on the validity checking code itself! --- 2830,2836 ---- Exp := Expression (Exp); end loop; ! -- Insert the validity check. Note that we do this with validity -- checks turned off, to avoid recursion, we do not want validity -- checks on the validity checking code itself! *************** package body Checks is *** 2826,2832 **** Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (Exp, Name_Req => True), ! Attribute_Name => Name_Valid))), Suppress => All_Checks); Validity_Checks_On := True; end Insert_Valid_Check; --- 2844,2851 ---- Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (Exp, Name_Req => True), ! Attribute_Name => Name_Valid)), ! Reason => CE_Invalid_Data), Suppress => All_Checks); Validity_Checks_On := True; end Insert_Valid_Check; *************** package body Checks is *** 2840,2846 **** Typ : constant Entity_Id := Etype (R_Cno); begin ! Rewrite (R_Cno, Make_Raise_Constraint_Error (Loc)); Set_Analyzed (R_Cno); Set_Etype (R_Cno, Typ); Set_Raises_Constraint_Error (R_Cno); --- 2859,2867 ---- Typ : constant Entity_Id := Etype (R_Cno); begin ! Rewrite (R_Cno, ! Make_Raise_Constraint_Error (Loc, ! Reason => CE_Range_Check_Failed)); Set_Analyzed (R_Cno); Set_Etype (R_Cno, Typ); Set_Raises_Constraint_Error (R_Cno); *************** package body Checks is *** 2897,2902 **** --- 2918,3021 ---- or else Vax_Float (E); end Range_Checks_Suppressed; + ------------------- + -- Remove_Checks -- + ------------------- + + procedure Remove_Checks (Expr : Node_Id) is + Discard : Traverse_Result; + + function Process (N : Node_Id) return Traverse_Result; + -- Process a single node during the traversal + + function Traverse is new Traverse_Func (Process); + -- The traversal function itself + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) not in N_Subexpr then + return Skip; + end if; + + Set_Do_Range_Check (N, False); + + case Nkind (N) is + when N_And_Then => + Discard := Traverse (Left_Opnd (N)); + return Skip; + + when N_Attribute_Reference => + Set_Do_Access_Check (N, False); + Set_Do_Overflow_Check (N, False); + + when N_Explicit_Dereference => + Set_Do_Access_Check (N, False); + + when N_Function_Call => + Set_Do_Tag_Check (N, False); + + when N_Indexed_Component => + Set_Do_Access_Check (N, False); + + when N_Op => + Set_Do_Overflow_Check (N, False); + + case Nkind (N) is + when N_Op_Divide => + Set_Do_Division_Check (N, False); + + when N_Op_And => + Set_Do_Length_Check (N, False); + + when N_Op_Mod => + Set_Do_Division_Check (N, False); + + when N_Op_Or => + Set_Do_Length_Check (N, False); + + when N_Op_Rem => + Set_Do_Division_Check (N, False); + + when N_Op_Xor => + Set_Do_Length_Check (N, False); + + when others => + null; + end case; + + when N_Or_Else => + Discard := Traverse (Left_Opnd (N)); + return Skip; + + when N_Selected_Component => + Set_Do_Access_Check (N, False); + Set_Do_Discriminant_Check (N, False); + + when N_Slice => + Set_Do_Access_Check (N, False); + + when N_Type_Conversion => + Set_Do_Length_Check (N, False); + Set_Do_Overflow_Check (N, False); + Set_Do_Tag_Check (N, False); + + when others => + null; + end case; + + return OK; + end Process; + + -- Start of processing for Remove_Checks + + begin + Discard := Traverse (Expr); + end Remove_Checks; + ---------------------------- -- Selected_Length_Checks -- ---------------------------- *************** package body Checks is *** 3274,3280 **** for Indx in 1 .. Ndims loop if not (Nkind (L_Index) = N_Raise_Constraint_Error ! or else Nkind (R_Index) = N_Raise_Constraint_Error) then Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); --- 3393,3400 ---- for Indx in 1 .. Ndims loop if not (Nkind (L_Index) = N_Raise_Constraint_Error ! or else ! Nkind (R_Index) = N_Raise_Constraint_Error) then Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); *************** package body Checks is *** 3351,3357 **** else declare ! Ndims : Nat := Number_Dimensions (T_Typ); begin -- Build the condition for the explicit dereference case --- 3471,3477 ---- else declare ! Ndims : Nat := Number_Dimensions (T_Typ); begin -- Build the condition for the explicit dereference case *************** package body Checks is *** 3372,3382 **** Cond := Guard_Access (Cond, Loc, Ck_Node); end if; ! Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond)); end if; return Ret_Result; - end Selected_Length_Checks; --------------------------- --- 3492,3504 ---- Cond := Guard_Access (Cond, Loc, Ck_Node); end if; ! Add_Check ! (Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Length_Check_Failed)); end if; return Ret_Result; end Selected_Length_Checks; --------------------------- *************** package body Checks is *** 4074,4080 **** for Indx in 1 .. Ndims loop if not (Nkind (L_Index) = N_Raise_Constraint_Error ! or else Nkind (R_Index) = N_Raise_Constraint_Error) then Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); --- 4196,4203 ---- for Indx in 1 .. Ndims loop if not (Nkind (L_Index) = N_Raise_Constraint_Error ! or else ! Nkind (R_Index) = N_Raise_Constraint_Error) then Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); *************** package body Checks is *** 4193,4203 **** Cond := Guard_Access (Cond, Loc, Ck_Node); end if; ! Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond)); end if; return Ret_Result; - end Selected_Range_Checks; ------------------------------- --- 4316,4328 ---- Cond := Guard_Access (Cond, Loc, Ck_Node); end if; ! Add_Check ! (Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Range_Check_Failed)); end if; return Ret_Result; end Selected_Range_Checks; ------------------------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/checks.ads gcc-3.3/gcc/ada/checks.ads *** gcc-3.2.3/gcc/ada/checks.ads 2002-05-04 03:27:35.000000000 +0000 --- gcc-3.3/gcc/ada/checks.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package Checks is *** 497,502 **** --- 496,506 ---- -- the sense of the 'Valid attribute returning True. Constraint_Error -- will be raised if the value is not valid. + procedure Remove_Checks (Expr : Node_Id); + -- Remove all checks from Expr except those that are only executed + -- conditionally (on the right side of And Then/Or Else. This call + -- removes only embedded checks (Do_Range_Check, Do_Overflow_Check). + private type Check_Result is array (Positive range 1 .. 2) of Node_Id; diff -Nrc3pad gcc-3.2.3/gcc/ada/cio.c gcc-3.3/gcc/ada/cio.c *** gcc-3.2.3/gcc/ada/cio.c 2002-05-04 03:27:36.000000000 +0000 --- gcc-3.3/gcc/ada/cio.c 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * C Implementation File * * * - * $Revision: 1.2.12.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/comperr.adb gcc-3.3/gcc/ada/comperr.adb *** gcc-3.2.3/gcc/ada/comperr.adb 2002-05-04 03:27:36.000000000 +0000 --- gcc-3.3/gcc/ada/comperr.adb 2002-11-15 01:45:29.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.3 $ -- -- -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Comperr is *** 76,84 **** --- 75,92 ---- (X : String; Code : Integer := 0) is + -- The procedures below output a "bug box" with information about + -- the cause of the compiler abort and about the preferred method + -- of reporting bugs. The default is a bug box appropriate for + -- the FSF version of GNAT. + procedure End_Line; -- Add blanks up to column 76, and then a final vertical bar + -------------- + -- End_Line -- + -------------- + procedure End_Line is begin Repeat_Char (' ', 76, '|'); *************** package body Comperr is *** 96,108 **** Abort_In_Progress := True; ! -- If errors have already occurred, then we guess that the abort may ! -- well be caused by previous errors, and we don't make too much fuss ! -- about it, since we want to let the programmer fix the errors first. -- Debug flag K disables this behavior (useful for debugging) ! if Errors_Detected /= 0 and then not Debug_Flag_K then Errout.Finalize; Set_Standard_Error; --- 104,116 ---- Abort_In_Progress := True; ! -- If any errors have already occurred, then we guess that the abort ! -- may well be caused by previous errors, and we don't make too much ! -- fuss about it, since we want to let programmer fix the errors first. -- Debug flag K disables this behavior (useful for debugging) ! if Total_Errors_Detected /= 0 and then not Debug_Flag_K then Errout.Finalize; Set_Standard_Error; *************** package body Comperr is *** 251,258 **** else Write_Str ! ("| Please submit a bug report, see" & ! " http://gcc.gnu.org/bugs.html."); End_Line; Write_Str --- 259,266 ---- else Write_Str ! ("| Please submit a bug report; see" & ! " http://gcc.gnu.org/bugs.html."); End_Line; Write_Str *************** package body Comperr is *** 270,276 **** End_Line; Write_Str ! ("| (concatenated together with no headers between files)."); End_Line; end if; --- 278,284 ---- End_Line; Write_Str ! ("| concatenated together with no headers between files."); End_Line; end if; diff -Nrc3pad gcc-3.2.3/gcc/ada/comperr.ads gcc-3.3/gcc/ada/comperr.ads *** gcc-3.2.3/gcc/ada/comperr.ads 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/comperr.ads 2002-11-15 01:45:29.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package Comperr is *** 57,63 **** -- information on the version number, type of abort, and source location. -- Normally the remaining text is of the following form: ! -- Please submit bug a report, see http://gcc.gnu.org/bugs.html. -- Include the entire contents of this bug box in the report. -- Include the exact gcc or gnatmake command that you entered. -- Also include sources listed below in gnatchop format --- 56,63 ---- -- information on the version number, type of abort, and source location. -- Normally the remaining text is of the following form: ! ! -- Please submit a bug report; see http://gcc.gnu.org/bugs.html. -- Include the entire contents of this bug box in the report. -- Include the exact gcc or gnatmake command that you entered. -- Also include sources listed below in gnatchop format diff -Nrc3pad gcc-3.2.3/gcc/ada/config-lang.in gcc-3.3/gcc/ada/config-lang.in *** gcc-3.2.3/gcc/ada/config-lang.in 2001-12-20 00:20:43.000000000 +0000 --- gcc-3.3/gcc/ada/config-lang.in 2002-11-13 21:19:51.000000000 +0000 *************** compilers="gnat1\$(exeext)" *** 34,37 **** --- 34,39 ---- stagestuff="gnatbind\$(exeext) gnat1\$(exeext)" + gtfiles="\$(srcdir)/ada/ada-tree.h \$(srcdir)/ada/gigi.h \$(srcdir)/ada/decl.c \$(srcdir)/ada/trans.c \$(srcdir)/ada/utils.c" + outputs=ada/Makefile diff -Nrc3pad gcc-3.2.3/gcc/ada/csets.adb gcc-3.3/gcc/ada/csets.adb *** gcc-3.2.3/gcc/ada/csets.adb 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/csets.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Csets is *** 168,176 **** X_FE : constant Character := Character'Val (16#FE#); X_FF : constant Character := Character'Val (16#FF#); ! ----------------------------- ! -- Definitions for Latin-1 -- ! ----------------------------- Fold_Latin_1 : Translate_Table := Translate_Table'( --- 167,175 ---- X_FE : constant Character := Character'Val (16#FE#); X_FF : constant Character := Character'Val (16#FF#); ! ------------------------------------------ ! -- Definitions for Latin-1 (ISO 8859-1) -- ! ------------------------------------------ Fold_Latin_1 : Translate_Table := Translate_Table'( *************** package body Csets is *** 243,251 **** others => ' '); ! ----------------------------- ! -- Definitions for Latin-2 -- ! ----------------------------- Fold_Latin_2 : Translate_Table := Translate_Table'( --- 242,250 ---- others => ' '); ! ------------------------------------------ ! -- Definitions for Latin-2 (ISO 8859-2) -- ! ------------------------------------------ Fold_Latin_2 : Translate_Table := Translate_Table'( *************** package body Csets is *** 318,326 **** others => ' '); ! ----------------------------- ! -- Definitions for Latin-3 -- ! ----------------------------- Fold_Latin_3 : Translate_Table := Translate_Table'( --- 317,325 ---- others => ' '); ! ------------------------------------------ ! -- Definitions for Latin-3 (ISO 8859-3) -- ! ------------------------------------------ Fold_Latin_3 : Translate_Table := Translate_Table'( *************** package body Csets is *** 393,401 **** others => ' '); ! ----------------------------- ! -- Definitions for Latin-4 -- ! ----------------------------- Fold_Latin_4 : Translate_Table := Translate_Table'( --- 392,400 ---- others => ' '); ! ------------------------------------------ ! -- Definitions for Latin-4 (ISO 8859-4) -- ! ------------------------------------------ Fold_Latin_4 : Translate_Table := Translate_Table'( *************** package body Csets is *** 543,548 **** --- 542,622 ---- others => ' '); + ------------------------------------------ + -- Definitions for Latin-9 (ISO 8859-9) -- + ------------------------------------------ + + Fold_Latin_9 : Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, + 'p' => 'P', X_EF => X_CF, + 'q' => 'Q', X_A8 => X_A6, + 'r' => 'R', X_B8 => X_B4, + 's' => 'S', X_BD => X_BC, + 't' => 'T', X_BE => X_FF, + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, + 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_FF => X_FF, + 'Q' => 'Q', X_A6 => X_A6, + 'R' => 'R', X_B4 => X_B4, + 'S' => 'S', X_BC => X_BC, + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + -------------------------------------------- -- Definitions for IBM PC (Code Page 437) -- -------------------------------------------- *************** package body Csets is *** 1024,1030 **** procedure Initialize is begin - -- Set Fold_Upper table from source code indication if Identifier_Character_Set = '1' --- 1098,1103 ---- *************** package body Csets is *** 1050,1055 **** --- 1123,1131 ---- elsif Identifier_Character_Set = '8' then Fold_Upper := Fold_IBM_PC_850; + elsif Identifier_Character_Set = '9' then + Fold_Upper := Fold_Latin_9; + elsif Identifier_Character_Set = 'f' then Fold_Upper := Fold_Full_Upper_Half; diff -Nrc3pad gcc-3.2.3/gcc/ada/csets.ads gcc-3.3/gcc/ada/csets.ads *** gcc-3.2.3/gcc/ada/csets.ads 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/csets.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** pragma Elaborate_Body (Csets); *** 64,76 **** -- The character set in use is specified by the value stored in -- Opt.Identifier_Character_Set, which has the following settings: ! -- '1' Latin-1 ! -- '2' Latin-2 ! -- '3' Latin-3 ! -- '4' Latin-4 ! -- '5' Latin-5 (Cyrillic ISO-8859-5) ! -- 'p' IBM PC (code page 437) ! -- '8' IBM PC (code page 850) -- 'f' Full upper set (all distinct) -- 'n' No upper characters (Ada/83 rules) -- 'w' Latin-1 plus wide characters also allowed --- 63,76 ---- -- The character set in use is specified by the value stored in -- Opt.Identifier_Character_Set, which has the following settings: ! -- '1' Latin-1 (ISO-8859-1) ! -- '2' Latin-2 (ISO-8859-2) ! -- '3' Latin-3 (ISO-8859-3) ! -- '4' Latin-4 (ISO-8859-4) ! -- '5' Latin-5 (ISO-8859-5, Cyrillic) ! -- 'p' IBM PC (code page 437) ! -- '8' IBM PC (code page 850) ! -- '9' Latin-9 (ISO-9959-9) -- 'f' Full upper set (all distinct) -- 'n' No upper characters (Ada/83 rules) -- 'w' Latin-1 plus wide characters also allowed diff -Nrc3pad gcc-3.2.3/gcc/ada/csinfo.adb gcc-3.3/gcc/ada/csinfo.adb *** gcc-3.2.3/gcc/ada/csinfo.adb 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/csinfo.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.12.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/cstand.adb gcc-3.3/gcc/ada/cstand.adb *** gcc-3.2.3/gcc/ada/cstand.adb 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/cstand.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.5.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body CStand is *** 353,359 **** Set_Ekind (Standard_Boolean, E_Enumeration_Type); Set_First_Literal (Standard_Boolean, Standard_False); Set_Etype (Standard_Boolean, Standard_Boolean); ! Init_Esize (Standard_Boolean, 8); Init_RM_Size (Standard_Boolean, 1); Set_Prim_Alignment (Standard_Boolean); --- 352,358 ---- Set_Ekind (Standard_Boolean, E_Enumeration_Type); Set_First_Literal (Standard_Boolean, Standard_False); Set_Etype (Standard_Boolean, Standard_Boolean); ! Init_Esize (Standard_Boolean, Standard_Character_Size); Init_RM_Size (Standard_Boolean, 1); Set_Prim_Alignment (Standard_Boolean); *************** package body CStand is *** 471,477 **** Set_Ekind (Standard_Character, E_Enumeration_Type); Set_Etype (Standard_Character, Standard_Character); ! Init_Size (Standard_Character, Standard_Character_Size); Set_Prim_Alignment (Standard_Character); Set_Is_Unsigned_Type (Standard_Character); --- 470,477 ---- Set_Ekind (Standard_Character, E_Enumeration_Type); Set_Etype (Standard_Character, Standard_Character); ! Init_Esize (Standard_Character, Standard_Character_Size); ! Init_RM_Size (Standard_Character, 8); Set_Prim_Alignment (Standard_Character); Set_Is_Unsigned_Type (Standard_Character); *************** package body CStand is *** 800,806 **** Set_Ekind (Any_Boolean, E_Enumeration_Type); Set_Scope (Any_Boolean, Standard_Standard); Set_Etype (Any_Boolean, Standard_Boolean); ! Init_Esize (Any_Boolean, 8); Init_RM_Size (Any_Boolean, 1); Set_Prim_Alignment (Any_Boolean); Set_Is_Unsigned_Type (Any_Boolean); --- 800,806 ---- Set_Ekind (Any_Boolean, E_Enumeration_Type); Set_Scope (Any_Boolean, Standard_Standard); Set_Etype (Any_Boolean, Standard_Boolean); ! Init_Esize (Any_Boolean, Standard_Character_Size); Init_RM_Size (Any_Boolean, 1); Set_Prim_Alignment (Any_Boolean); Set_Is_Unsigned_Type (Any_Boolean); *************** package body CStand is *** 813,819 **** Set_Etype (Any_Character, Any_Character); Set_Is_Unsigned_Type (Any_Character); Set_Is_Character_Type (Any_Character); ! Init_Size (Any_Character, Standard_Character_Size); Set_Prim_Alignment (Any_Character); Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); Make_Name (Any_Character, "a character type"); --- 813,820 ---- Set_Etype (Any_Character, Any_Character); Set_Is_Unsigned_Type (Any_Character); Set_Is_Character_Type (Any_Character); ! Init_Esize (Any_Character, Standard_Character_Size); ! Init_RM_Size (Any_Character, 8); Set_Prim_Alignment (Any_Character); Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); Make_Name (Any_Character, "a character type"); diff -Nrc3pad gcc-3.2.3/gcc/ada/cstand.ads gcc-3.3/gcc/ada/cstand.ads *** gcc-3.2.3/gcc/ada/cstand.ads 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/cstand.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/cstreams.c gcc-3.3/gcc/ada/cstreams.c *** gcc-3.2.3/gcc/ada/cstreams.c 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/cstreams.c 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * Auxiliary C functions for Interfaces.C.Streams * * * - * $Revision: 1.2.12.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- *************** *** 49,68 **** #include "adaint.h" ! #ifdef __EMX__ ! int max_path_len = _MAX_PATH; ! #elif defined (VMS) #include ! int max_path_len = 255; /* PATH_MAX */ ! ! #elif defined (__vxworks) || defined (__OPENNT) ! ! int max_path_len = PATH_MAX; ! ! #else #ifdef linux - /* Don't use macros on GNU/Linux since they cause incompatible changes between glibc 2.0 and 2.1 */ --- 48,58 ---- #include "adaint.h" ! #ifdef VMS #include ! #endif #ifdef linux /* Don't use macros on GNU/Linux since they cause incompatible changes between glibc 2.0 and 2.1 */ *************** int max_path_len = PATH_MAX; *** 75,86 **** #ifdef stdout # undef stdout #endif - - #endif - - #include - - int max_path_len = MAXPATHLEN; #endif /* The _IONBF value in CYGNUS or MINGW32 stdio.h is wrong. */ --- 65,70 ---- *************** __gnat_full_name (nam, buffer) *** 182,192 **** #if defined(__EMX__) || defined (__MINGW32__) /* If this is a device file return it as is; under Windows NT and OS/2 a device file end with ":". */ ! if (nam [strlen (nam) - 1] == ':') strcpy (buffer, nam); else { ! _fullpath (buffer, nam, max_path_len); for (p = buffer; *p; p++) if (*p == '/') --- 166,176 ---- #if defined(__EMX__) || defined (__MINGW32__) /* If this is a device file return it as is; under Windows NT and OS/2 a device file end with ":". */ ! if (nam[strlen (nam) - 1] == ':') strcpy (buffer, nam); else { ! _fullpath (buffer, nam, __gnat_max_path_len); for (p = buffer; *p; p++) if (*p == '/') *************** __gnat_full_name (nam, buffer) *** 211,220 **** strcpy (buffer, __gnat_to_host_file_spec (buffer)); else { ! char nambuffer [MAXPATHLEN]; strcpy (nambuffer, buffer); ! strcpy (buffer, getcwd (buffer, max_path_len, 0)); strcat (buffer, "/"); strcat (buffer, nambuffer); strcpy (buffer, __gnat_to_host_file_spec (buffer)); --- 195,204 ---- strcpy (buffer, __gnat_to_host_file_spec (buffer)); else { ! char *nambuffer = alloca (__gnat_max_path_len); strcpy (nambuffer, buffer); ! strcpy (buffer, getcwd (buffer, __gnat_max_path_len, 0)); strcat (buffer, "/"); strcat (buffer, nambuffer); strcpy (buffer, __gnat_to_host_file_spec (buffer)); *************** __gnat_full_name (nam, buffer) *** 225,231 **** #else if (nam[0] != '/') { ! p = getcwd (buffer, max_path_len); if (p == 0) { buffer[0] = '\0'; --- 209,215 ---- #else if (nam[0] != '/') { ! p = getcwd (buffer, __gnat_max_path_len); if (p == 0) { buffer[0] = '\0'; diff -Nrc3pad gcc-3.2.3/gcc/ada/cuintp.c gcc-3.3/gcc/ada/cuintp.c *** gcc-3.2.3/gcc/ada/cuintp.c 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/cuintp.c 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * C Implementation File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/.cvsignore gcc-3.3/gcc/ada/.cvsignore *** gcc-3.2.3/gcc/ada/.cvsignore 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/.cvsignore 2002-05-31 10:47:33.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + gnat_ug_unx.info* + gnat_ug_vms.info* + gnat_ug_vxw.info* + gnat_ug_wnt.info* + gnat_rm.info* + gnat-style.info* diff -Nrc3pad gcc-3.2.3/gcc/ada/debug_a.adb gcc-3.3/gcc/ada/debug_a.adb *** gcc-3.2.3/gcc/ada/debug_a.adb 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/debug_a.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/debug_a.ads gcc-3.3/gcc/ada/debug_a.ads *** gcc-3.2.3/gcc/ada/debug_a.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/debug_a.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/debug.adb gcc-3.3/gcc/ada/debug.adb *** gcc-3.2.3/gcc/ada/debug.adb 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/debug.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Debug is *** 57,63 **** -- dn Generate messages for node/list allocation -- do Print source from tree (original code only) -- dp Generate messages for parser scope stack push/pops ! -- dq -- dr Generate parser resynchronization messages -- ds Print source from tree (including original and generated stuff) -- dt Print full tree --- 56,62 ---- -- dn Generate messages for node/list allocation -- do Print source from tree (original code only) -- dp Generate messages for parser scope stack push/pops ! -- dq No auto-alignment of small records -- dr Generate parser resynchronization messages -- ds Print source from tree (including original and generated stuff) -- dt Print full tree *************** package body Debug is *** 74,86 **** -- dD Delete elaboration checks in inner level routines -- dE Apply elaboration checks to predefined units -- dF Front end data layout enabled. ! -- dG Generate input showing file creating info for debug file -- dH Hold (kill) call to gigi -- dI Inhibit internal name numbering in gnatG listing -- dJ Output debugging trace info for JGNAT (Java VM version of GNAT) -- dK Kill all error messages -- dL Output trace information on elaboration checking ! -- dM Modified ali file output -- dN Do not generate file/line exception messages -- dO Output immediate error messages -- dP Do not check for controlled objects in preelaborable packages --- 73,85 ---- -- dD Delete elaboration checks in inner level routines -- dE Apply elaboration checks to predefined units -- dF Front end data layout enabled. ! -- dG -- dH Hold (kill) call to gigi -- dI Inhibit internal name numbering in gnatG listing -- dJ Output debugging trace info for JGNAT (Java VM version of GNAT) -- dK Kill all error messages -- dL Output trace information on elaboration checking ! -- dM -- dN Do not generate file/line exception messages -- dO Output immediate error messages -- dP Do not check for controlled objects in preelaborable packages *************** package body Debug is *** 124,130 **** -- do -- dp -- dq ! -- dr List additional restrictions that may be specified -- ds -- dt -- du List units as they are acquired --- 123,129 ---- -- do -- dp -- dq ! -- dr -- ds -- dt -- du List units as they are acquired *************** package body Debug is *** 166,172 **** -- dr -- ds -- dt ! -- du -- dv -- dw Prints the list of units withed by the unit currently explored -- dx --- 165,171 ---- -- dr -- ds -- dt ! -- du List units as their ali files are acquired -- dv -- dw Prints the list of units withed by the unit currently explored -- dx *************** package body Debug is *** 192,197 **** --- 191,200 ---- -- resolved, or evaluated. This option is useful for finding out -- exactly where a bomb during semantic analysis is occurring. + -- dA Normally the output from -gnatR excludes private types and all + -- internal entities. This debug flag causes representation info + -- for these entities to be output as well. + -- db In Exp_Dbug, certain type names are encoded to include debugging -- information. This debug switch causes lines to be output showing -- the encodings used. *************** package body Debug is *** 238,246 **** -- non-source generated null statements, and freeze nodes, which -- are normally omitted in -gnatG mode. - -- dG Print trace information showing calls to Create_Debug_Source and - -- Write_Debug_Line. Used for debugging -gnatD operation problems. - -- dh Generates a table at the end of a compilation showing how the hash -- table chains built by the Namet package are loaded. This is useful -- in ensuring that the hashing algorithm (in Namet.Hash) is working --- 241,246 ---- *************** package body Debug is *** 284,294 **** -- attempting to generate code with this flag set may blow up. -- The flag also forces the use of 64-bits for Long_Integer. - -- dM Generate modified ALI output. Several ALI extensions are being - -- developed for version 3.15w, and this switch is used to enable - -- these extensions. This switch will disappear when this work is - -- completed. - -- dn Generate messages for node/list allocation. Each time a node or -- list header is allocated, a line of output is generated. Certain -- other basic tree operations also cause a line of output to be --- 284,289 ---- *************** package body Debug is *** 308,313 **** --- 303,314 ---- -- pushed or popped. Useful in debugging situations where the -- parser scope stack ends up incorrectly synchronized + -- dq In layout version 1.38, 2002/01/12, a circuit was implemented + -- to give decent default alignment to short records that had no + -- specific alignment set. This debug option restores the previous + -- behavior of giving such records poor alignments, typically 1. + -- This may be useful in dealing with transition. + -- dr Generate parser resynchronization messages. Normally the parser -- resynchronizes quietly. With this debug option, two messages -- are generated, one when the parser starts a resynchronization *************** package body Debug is *** 463,471 **** -- the algorithm used to determine a correct order of elaboration. This -- is useful in diagnosing any problems in its behavior. - -- dr List restrictions which have not been specified, but could have - -- been without causing bind errors. - -- du List unit name and file name for each unit as it is read in ------------------------------------------------------------ --- 464,469 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/debug.ads gcc-3.3/gcc/ada/debug.ads *** gcc-3.2.3/gcc/ada/debug.ads 2002-05-04 03:27:37.000000000 +0000 --- gcc-3.3/gcc/ada/debug.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** package Debug is *** 37,52 **** pragma Preelaborate (Debug); -- This package contains global flags used to control the inclusion ! -- of debugging code in various phases of the compiler. ------------------------- -- Dynamic Debug Flags -- ------------------------- ! -- Thirty six flags that can be used to active various specialized -- debugging output information. The flags are preset to False, which -- corresponds to the given output being suppressed. The individual ! -- flags can be turned on using the undocumented switch /dxxx where -- xxx is a string of letters for flags to be turned on. Documentation -- on the current usage of these flags is contained in the body of Debug -- rather than the spec, so that we don't have to recompile the world --- 36,52 ---- pragma Preelaborate (Debug); -- This package contains global flags used to control the inclusion ! -- of debugging code in various phases of the compiler. Some of these ! -- flags are also used by the binder and gnatmake. ------------------------- -- Dynamic Debug Flags -- ------------------------- ! -- Sixty two flags that can be used to active various specialized -- debugging output information. The flags are preset to False, which -- corresponds to the given output being suppressed. The individual ! -- flags can be turned on using the undocumented switch dxxx where -- xxx is a string of letters for flags to be turned on. Documentation -- on the current usage of these flags is contained in the body of Debug -- rather than the spec, so that we don't have to recompile the world diff -Nrc3pad gcc-3.2.3/gcc/ada/dec.ads gcc-3.3/gcc/ada/dec.ads *** gcc-3.2.3/gcc/ada/dec.ads 2002-05-04 03:27:38.000000000 +0000 --- gcc-3.3/gcc/ada/dec.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/dec-io.adb gcc-3.3/gcc/ada/dec-io.adb *** gcc-3.2.3/gcc/ada/dec-io.adb 2002-05-04 03:27:38.000000000 +0000 --- gcc-3.3/gcc/ada/dec-io.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/dec-io.ads gcc-3.3/gcc/ada/dec-io.ads *** gcc-3.2.3/gcc/ada/dec-io.ads 2002-05-04 03:27:38.000000000 +0000 --- gcc-3.3/gcc/ada/dec-io.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/decl.c gcc-3.3/gcc/ada/decl.c *** gcc-3.2.3/gcc/ada/decl.c 2002-05-04 03:27:38.000000000 +0000 --- gcc-3.3/gcc/ada/decl.c 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** * * * C Implementation File * * * - * $Revision: 1.9.10.1 $ * * ! * Copyright (C) 1992-2001, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * --- 6,13 ---- * * * 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- * *************** static void components_to_record PARAMS *** 100,106 **** static int compare_field_bitpos PARAMS ((const PTR, const PTR)); static Uint annotate_value PARAMS ((tree)); static void annotate_rep PARAMS ((Entity_Id, tree)); ! static tree compute_field_positions PARAMS ((tree, tree, tree, tree)); static tree validate_size PARAMS ((Uint, tree, Entity_Id, enum tree_code, int, int)); static void set_rm_size PARAMS ((Uint, tree, Entity_Id)); --- 99,106 ---- static int compare_field_bitpos PARAMS ((const PTR, const PTR)); static Uint annotate_value PARAMS ((tree)); static void annotate_rep PARAMS ((Entity_Id, tree)); ! static tree compute_field_positions PARAMS ((tree, tree, tree, tree, ! unsigned int)); static tree validate_size PARAMS ((Uint, tree, Entity_Id, enum tree_code, int, int)); static void set_rm_size PARAMS ((Uint, tree, Entity_Id)); *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 579,596 **** if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size)) { ! tree gnu_temp = gnu_expr; ! ! /* Strip off any conversions in GNU_EXPR since ! they can't be changing the size to allocate. */ ! while (TREE_CODE (gnu_temp) == UNCHECKED_CONVERT_EXPR) ! gnu_temp = TREE_OPERAND (gnu_temp, 0); ! ! gnu_size = TYPE_SIZE (TREE_TYPE (gnu_temp)); if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size)) gnu_size = build (WITH_RECORD_EXPR, bitsizetype, ! gnu_size, gnu_temp); } } --- 579,589 ---- if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size)) { ! gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr)); if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size)) gnu_size = build (WITH_RECORD_EXPR, bitsizetype, ! gnu_size, gnu_expr); } } *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 687,692 **** --- 680,694 ---- check_ok_for_atomic (gnu_inner, gnat_entity, 1); } + /* Now check if the type of the object allows atomic access. Note + that we must test the type, even if this object has size and + alignment to allow such access, because we will be going + inside the padded record to assign to the object. We could fix + this by always copying via an intermediate value, but it's not + clear it's worth the effort. */ + if (Is_Atomic (gnat_entity)) + check_ok_for_atomic (gnu_type, gnat_entity, 0); + /* Make a new type with the desired size and alignment, if needed. */ gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, "PAD", 0, definition, 1); *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 1042,1061 **** || Address_Taken (gnat_entity) || Is_Aliased (gnat_entity) || Is_Aliased (Etype (gnat_entity)))) ! DECL_CONST_CORRESPONDING_VAR (gnu_decl) ! = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, gnu_expr, 0, Is_Public (gnat_entity), 0, ! static_p, 0); ! ! if (Is_Atomic (gnat_entity)) ! check_ok_for_atomic (gnu_decl, gnat_entity, 0); /* If this is declared in a block that contains an block with an exception handler, we must force this variable in memory to suppress an invalid optimization. */ ! if (Has_Nested_Block_With_Handler (Scope (gnat_entity))) { ! mark_addressable (gnu_decl); flush_addressof (gnu_decl); } --- 1044,1061 ---- || Address_Taken (gnat_entity) || Is_Aliased (gnat_entity) || Is_Aliased (Etype (gnat_entity)))) ! SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, ! create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, gnu_expr, 0, Is_Public (gnat_entity), 0, ! static_p, 0)); /* If this is declared in a block that contains an block with an exception handler, we must force this variable in memory to suppress an invalid optimization. */ ! if (Has_Nested_Block_With_Handler (Scope (gnat_entity)) ! && Exception_Mechanism != GCC_ZCX) { ! gnat_mark_addressable (gnu_decl); flush_addressof (gnu_decl); } *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 1184,1190 **** if (! integer_zerop (gnu_modulus)) { TYPE_MODULAR_P (gnu_type) = 1; ! TYPE_MODULUS (gnu_type) = gnu_modulus; gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus, convert (gnu_type, integer_one_node))); } --- 1184,1190 ---- if (! integer_zerop (gnu_modulus)) { TYPE_MODULAR_P (gnu_type) = 1; ! SET_TYPE_MODULUS (gnu_type, gnu_modulus); gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus, convert (gnu_type, integer_one_node))); } *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 1308,1314 **** gnu_field_type, gnu_type, 1, 0, 0, 1), finish_record_type (gnu_type, gnu_field, 0, 0); TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1; ! TYPE_ADA_SIZE (gnu_type) = bitsize_int (esize); } break; --- 1308,1314 ---- gnu_field_type, gnu_type, 1, 0, 0, 1), finish_record_type (gnu_type, gnu_field, 0, 0); TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1; ! SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize)); } break; *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 1320,1327 **** { gnu_type = make_signed_type (esize); TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; ! TYPE_DIGITS_VALUE (gnu_type) ! = UI_To_Int (Digits_Value (gnat_entity)); break; } --- 1320,1327 ---- { gnu_type = make_signed_type (esize); TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; ! SET_TYPE_DIGITS_VALUE (gnu_type, ! UI_To_Int (Digits_Value (gnat_entity))); break; } *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 1619,1636 **** = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type; TYPE_MODE (gnu_type) = BLKmode; TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem); ! TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type) = gnu_type; /* If the maximum size doesn't overflow, use it. */ if (TREE_CODE (gnu_max_size) == INTEGER_CST && ! TREE_OVERFLOW (gnu_max_size)) ! { ! TYPE_SIZE (tem) ! = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); ! TYPE_SIZE_UNIT (tem) ! = size_binop (MIN_EXPR, gnu_max_size_unit, ! TYPE_SIZE_UNIT (tem)); ! } create_type_decl (create_concat_name (gnat_entity, "XUA"), tem, 0, ! Comes_From_Source (gnat_entity), --- 1619,1636 ---- = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type; TYPE_MODE (gnu_type) = BLKmode; TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem); ! SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type); /* If the maximum size doesn't overflow, use it. */ if (TREE_CODE (gnu_max_size) == INTEGER_CST && ! TREE_OVERFLOW (gnu_max_size)) ! TYPE_SIZE (tem) ! = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); ! if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST ! && ! TREE_OVERFLOW (gnu_max_size_unit)) ! TYPE_SIZE_UNIT (tem) ! = size_binop (MIN_EXPR, gnu_max_size_unit, ! TYPE_SIZE_UNIT (tem)); create_type_decl (create_concat_name (gnat_entity, "XUA"), tem, 0, ! Comes_From_Source (gnat_entity), *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 1647,1653 **** DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node; DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = bitsize_zero_node; ! TYPE_UNCONSTRAINED_ARRAY (tem) = gnu_type; TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem; /* Give the thin pointer type a name. */ --- 1647,1653 ---- DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node; DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = bitsize_zero_node; ! SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type); TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem; /* Give the thin pointer type a name. */ *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 1977,1982 **** --- 1977,1984 ---- && contains_placeholder_p (TYPE_SIZE (gnu_type)) && ! (TREE_CODE (gnu_max_size) == INTEGER_CST && TREE_OVERFLOW (gnu_max_size)) + && ! (TREE_CODE (gnu_max_size_unit) == INTEGER_CST + && TREE_OVERFLOW (gnu_max_size_unit)) && ! max_overflow) { TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size, *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2023,2031 **** gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl); save_gnu_tree (gnat_entity, NULL_TREE, 0); ! if (TREE_CODE (gnu_inner_type) == RECORD_TYPE ! && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type) ! || TYPE_IS_PADDING_P (gnu_inner_type))) gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type)); /* We need to point the type we just made to our index type so --- 2025,2033 ---- gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl); save_gnu_tree (gnat_entity, NULL_TREE, 0); ! while (TREE_CODE (gnu_inner_type) == RECORD_TYPE ! && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type) ! || TYPE_IS_PADDING_P (gnu_inner_type))) gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type)); /* We need to point the type we just made to our index type so *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2064,2081 **** TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1; } ! TYPE_ACTUAL_BOUNDS (gnu_inner_type) = NULL_TREE; for (gnat_index = First_Index (gnat_entity); Present (gnat_index); gnat_index = Next_Index (gnat_index)) ! TYPE_ACTUAL_BOUNDS (gnu_inner_type) ! = tree_cons (NULL_TREE, get_unpadded_type (Etype (gnat_index)), ! TYPE_ACTUAL_BOUNDS (gnu_inner_type)); if (Convention (gnat_entity) != Convention_Fortran) ! TYPE_ACTUAL_BOUNDS (gnu_inner_type) ! = nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)); if (TREE_CODE (gnu_type) == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type)) --- 2066,2083 ---- TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1; } ! SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE); for (gnat_index = First_Index (gnat_entity); Present (gnat_index); gnat_index = Next_Index (gnat_index)) ! SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, ! tree_cons (NULL_TREE, get_unpadded_type (Etype (gnat_index)), ! TYPE_ACTUAL_BOUNDS (gnu_inner_type))); if (Convention (gnat_entity) != Convention_Fortran) ! SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, ! nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type))); if (TREE_CODE (gnu_type) == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type)) *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2152,2158 **** the tree. */ case E_Record_Type: - #if 0 if (Has_Complex_Representation (gnat_entity)) { gnu_type --- 2154,2159 ---- *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2164,2176 **** (Type_Definition (Declaration_Node (gnat_entity))))))))); ! /* ??? For now, don't use Complex if the real type is shorter than ! a word. */ ! if (GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (gnu_type))) ! >= BITS_PER_WORD) ! break; } - #endif { Node_Id full_definition = Declaration_Node (gnat_entity); --- 2165,2173 ---- (Type_Definition (Declaration_Node (gnat_entity))))))))); ! ! break; } { Node_Id full_definition = Declaration_Node (gnat_entity); *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2469,2475 **** tree gnu_field_list = 0; tree gnu_pos_list = compute_field_positions (gnu_orig_type, NULL_TREE, ! size_zero_node, bitsize_zero_node); tree gnu_subst_list = substitution_list (gnat_entity, gnat_base_type, NULL_TREE, definition); --- 2466,2473 ---- tree gnu_field_list = 0; tree gnu_pos_list = compute_field_positions (gnu_orig_type, NULL_TREE, ! size_zero_node, bitsize_zero_node, ! BIGGEST_ALIGNMENT); tree gnu_subst_list = substitution_list (gnat_entity, gnat_base_type, NULL_TREE, definition); *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2485,2491 **** gnu_pos_list = compute_field_positions (gnat_to_gnu_type (Etype (gnat_root_type)), ! gnu_pos_list, size_zero_node, bitsize_zero_node); if (Present (Parent_Subtype (gnat_root_type))) gnu_subst_list --- 2483,2490 ---- gnu_pos_list = compute_field_positions (gnat_to_gnu_type (Etype (gnat_root_type)), ! gnu_pos_list, size_zero_node, bitsize_zero_node, ! BIGGEST_ALIGNMENT); if (Present (Parent_Subtype (gnat_root_type))) gnu_subst_list *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2511,2521 **** = TREE_VALUE (purpose_member (gnu_old_field, gnu_pos_list)); tree gnu_pos = TREE_PURPOSE (gnu_offset); ! tree gnu_bitpos = TREE_VALUE (gnu_offset); tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); tree gnu_size = TYPE_SIZE (gnu_field_type); tree gnu_new_pos = 0; tree gnu_field; /* If there was a component clause, the field types must be --- 2510,2523 ---- = TREE_VALUE (purpose_member (gnu_old_field, gnu_pos_list)); tree gnu_pos = TREE_PURPOSE (gnu_offset); ! tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset)); tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); tree gnu_size = TYPE_SIZE (gnu_field_type); tree gnu_new_pos = 0; + unsigned int offset_align + = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)), + 1); tree gnu_field; /* If there was a component clause, the field types must be *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2561,2572 **** if (! TREE_CONSTANT (gnu_pos)) { ! normalize_offset (&gnu_pos, &gnu_bitpos, ! DECL_OFFSET_ALIGN (gnu_old_field)); DECL_FIELD_OFFSET (gnu_field) = gnu_pos; DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos; ! SET_DECL_OFFSET_ALIGN ! (gnu_field, DECL_OFFSET_ALIGN (gnu_old_field)); DECL_SIZE (gnu_field) = gnu_size; DECL_SIZE_UNIT (gnu_field) = convert (sizetype, --- 2563,2572 ---- if (! TREE_CONSTANT (gnu_pos)) { ! normalize_offset (&gnu_pos, &gnu_bitpos, offset_align); DECL_FIELD_OFFSET (gnu_field) = gnu_pos; DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos; ! SET_DECL_OFFSET_ALIGN (gnu_field, offset_align); DECL_SIZE (gnu_field) = gnu_size; DECL_SIZE_UNIT (gnu_field) = convert (sizetype, *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2577,2585 **** DECL_INTERNAL_P (gnu_field) = DECL_INTERNAL_P (gnu_old_field); ! DECL_ORIGINAL_FIELD (gnu_field) ! = DECL_ORIGINAL_FIELD (gnu_old_field) != 0 ! ? DECL_ORIGINAL_FIELD (gnu_old_field) : gnu_old_field; DECL_DISCRIMINANT_NUMBER (gnu_field) = DECL_DISCRIMINANT_NUMBER (gnu_old_field); TREE_THIS_VOLATILE (gnu_field) --- 2577,2586 ---- DECL_INTERNAL_P (gnu_field) = DECL_INTERNAL_P (gnu_old_field); ! SET_DECL_ORIGINAL_FIELD (gnu_field, ! (DECL_ORIGINAL_FIELD (gnu_old_field) != 0 ! ? DECL_ORIGINAL_FIELD (gnu_old_field) ! : gnu_old_field)); DECL_DISCRIMINANT_NUMBER (gnu_field) = DECL_DISCRIMINANT_NUMBER (gnu_old_field); TREE_THIS_VOLATILE (gnu_field) *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2598,2604 **** TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type); TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type); ! TYPE_ADA_SIZE (gnu_type) = TYPE_ADA_SIZE (gnu_base_type); if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST && contains_placeholder_p (TYPE_SIZE (gnu_type))) --- 2599,2605 ---- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type); TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type); ! SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type)); if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST && contains_placeholder_p (TYPE_SIZE (gnu_type))) *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2623,2632 **** && contains_placeholder_p (TYPE_ADA_SIZE (gnu_type))) for (gnu_temp = gnu_subst_list; gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) ! TYPE_ADA_SIZE (gnu_type) ! = substitute_in_expr (TYPE_ADA_SIZE (gnu_type), TREE_PURPOSE (gnu_temp), ! TREE_VALUE (gnu_temp)); /* Recompute the mode of this record type now that we know its actual size. */ --- 2624,2633 ---- && contains_placeholder_p (TYPE_ADA_SIZE (gnu_type))) for (gnu_temp = gnu_subst_list; gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) ! SET_TYPE_ADA_SIZE (gnu_type, ! substitute_in_expr (TYPE_ADA_SIZE (gnu_type), TREE_PURPOSE (gnu_temp), ! TREE_VALUE (gnu_temp))); /* Recompute the mode of this record type now that we know its actual size. */ *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2763,2768 **** --- 2764,2777 ---- && ! Is_Constrained (gnat_desig_full)) gnat_desig_full = Etype (gnat_desig_full); + /* If the designated type is a subtype of an incomplete record type, + use the parent type to avoid order of elaboration issues. This + can lose some code efficiency, but there is no alternative. */ + if (Present (gnat_desig_full) + && Ekind (gnat_desig_full) == E_Record_Subtype + && Ekind (Etype (gnat_desig_full)) == E_Record_Type) + gnat_desig_full = Etype (gnat_desig_full); + /* If we are pointing to an incomplete type whose completion is an unconstrained array, make a fat pointer type instead of a pointer to VOID. The two types in our fields will be pointers to VOID and *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 2808,2814 **** if (gnu_type == 0) { gnu_type = make_node (RECORD_TYPE); ! TYPE_UNCONSTRAINED_ARRAY (gnu_type) = gnu_old; TYPE_POINTER_TO (gnu_old) = gnu_type; set_lineno (gnat_entity, 0); --- 2817,2823 ---- if (gnu_type == 0) { gnu_type = make_node (RECORD_TYPE); ! SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old); TYPE_POINTER_TO (gnu_old) = gnu_type; set_lineno (gnat_entity, 0); *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 3416,3422 **** if (Present (Interface_Name (gnat_entity)) || ! (Is_Imported (gnat_entity) || Is_Exported (gnat_entity))) ! gnu_ext_name = create_concat_name (gnat_entity, 0); set_lineno (gnat_entity, 0); --- 3425,3443 ---- if (Present (Interface_Name (gnat_entity)) || ! (Is_Imported (gnat_entity) || Is_Exported (gnat_entity))) ! { ! gnu_ext_name = create_concat_name (gnat_entity, 0); ! ! /* If there wasn't a specified Interface_Name, use this for the ! main name of the entity. This will cause GCC to allow ! qualification of a nested subprogram with a unique ID. We ! need this in case there is an overloaded subprogram somewhere ! up the scope chain. ! ! ??? This may be a kludge. */ ! if (No (Interface_Name (gnat_entity))) ! gnu_entity_id = gnu_ext_name; ! } set_lineno (gnat_entity, 0); *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 3579,3585 **** if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind)) { if (Is_Tagged_Type (gnat_entity)) ! TYPE_ALIGN_OK_P (gnu_type) = 1; if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity)) TYPE_BY_REFERENCE_P (gnu_type) = 1; --- 3600,3606 ---- if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind)) { if (Is_Tagged_Type (gnat_entity)) ! TYPE_ALIGN_OK (gnu_type) = 1; if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity)) TYPE_BY_REFERENCE_P (gnu_type) = 1; *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 3650,3677 **** if (TREE_CODE (gnu_type) == RECORD_TYPE && operand_equal_p (TYPE_ADA_SIZE (gnu_type), TYPE_SIZE (gnu_type), 0)) - TYPE_ADA_SIZE (gnu_type) = TYPE_SIZE (gnu_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_SIZE (gnu_type), - get_identifier ("SIZE"), - definition, 0); - else if (TREE_CODE (gnu_type) == RECORD_TYPE) { - TYPE_ADA_SIZE (gnu_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_ADA_SIZE (gnu_type), - get_identifier ("RM_SIZE"), - definition, 0); TYPE_SIZE (gnu_type) = elaborate_expression_1 (gnat_entity, gnat_entity, TYPE_SIZE (gnu_type), get_identifier ("SIZE"), definition, 0); ! TYPE_SIZE_UNIT (gnu_type) ! = elaborate_expression_1 (gnat_entity, gnat_entity, ! TYPE_SIZE_UNIT (gnu_type), ! get_identifier ("SIZE_UNIT"), ! definition, 0); } else { --- 3671,3683 ---- if (TREE_CODE (gnu_type) == RECORD_TYPE && operand_equal_p (TYPE_ADA_SIZE (gnu_type), TYPE_SIZE (gnu_type), 0)) { TYPE_SIZE (gnu_type) = elaborate_expression_1 (gnat_entity, gnat_entity, TYPE_SIZE (gnu_type), get_identifier ("SIZE"), definition, 0); ! SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type)); } else { *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 3680,3690 **** TYPE_SIZE (gnu_type), get_identifier ("SIZE"), definition, 0); TYPE_SIZE_UNIT (gnu_type) ! = elaborate_expression_1 (gnat_entity, gnat_entity, ! TYPE_SIZE_UNIT (gnu_type), ! get_identifier ("SIZE_UNIT"), ! definition, 0); } } --- 3686,3713 ---- TYPE_SIZE (gnu_type), get_identifier ("SIZE"), definition, 0); + + /* ??? For now, store the size as a multiple of the alignment + in bytes so that we can see the alignment from the tree. */ TYPE_SIZE_UNIT (gnu_type) ! = build_binary_op ! (MULT_EXPR, sizetype, ! elaborate_expression_1 ! (gnat_entity, gnat_entity, ! build_binary_op (EXACT_DIV_EXPR, sizetype, ! TYPE_SIZE_UNIT (gnu_type), ! size_int (TYPE_ALIGN (gnu_type) ! / BITS_PER_UNIT)), ! get_identifier ("SIZE_A_UNIT"), ! definition, 0), ! size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); ! ! if (TREE_CODE (gnu_type) == RECORD_TYPE) ! SET_TYPE_ADA_SIZE (gnu_type, ! elaborate_expression_1 (gnat_entity, gnat_entity, ! TYPE_ADA_SIZE (gnu_type), ! get_identifier ("RM_SIZE"), ! definition, 0)); } } *************** gnat_to_gnu_entity (gnat_entity, gnu_exp *** 3699,3711 **** { tree gnu_field = get_gnu_tree (gnat_temp); if (TREE_CODE (DECL_FIELD_OFFSET (gnu_field)) != INTEGER_CST && ! contains_placeholder_p (DECL_FIELD_OFFSET (gnu_field))) DECL_FIELD_OFFSET (gnu_field) ! = elaborate_expression_1 (gnat_temp, gnat_temp, ! DECL_FIELD_OFFSET (gnu_field), ! get_identifier ("OFFSET"), ! definition, 0); } gnu_type = build_qualified_type (gnu_type, --- 3722,3746 ---- { tree gnu_field = get_gnu_tree (gnat_temp); + /* ??? Unfortunately, GCC needs to be able to prove the + alignment of this offset and if it's a variable, it can't. + In GCC 3.2, we'll use DECL_OFFSET_ALIGN in some way, but + right now, we have to put in an explicit multiply and + divide by that value. */ if (TREE_CODE (DECL_FIELD_OFFSET (gnu_field)) != INTEGER_CST && ! contains_placeholder_p (DECL_FIELD_OFFSET (gnu_field))) DECL_FIELD_OFFSET (gnu_field) ! = build_binary_op ! (MULT_EXPR, sizetype, ! elaborate_expression_1 ! (gnat_temp, gnat_temp, ! build_binary_op (EXACT_DIV_EXPR, sizetype, ! DECL_FIELD_OFFSET (gnu_field), ! size_int (DECL_OFFSET_ALIGN (gnu_field) ! / BITS_PER_UNIT)), ! get_identifier ("OFFSET"), ! definition, 0), ! size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT)); } gnu_type = build_qualified_type (gnu_type, *************** substitution_list (gnat_subtype, gnat_ty *** 4009,4015 **** /* For the following two functions: for each GNAT entity, the GCC tree node used as a dummy for that entity, if any. */ ! static tree *dummy_node_table; /* Initialize the above table. */ --- 4044,4050 ---- /* For the following two functions: for each GNAT entity, the GCC tree node used as a dummy for that entity, if any. */ ! static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table; /* Initialize the above table. */ *************** init_dummy_type () *** 4018,4025 **** { Node_Id gnat_node; ! dummy_node_table = (tree *) xmalloc (max_gnat_nodes * sizeof (tree)); ! ggc_add_tree_root (dummy_node_table, max_gnat_nodes); for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++) dummy_node_table[gnat_node] = NULL_TREE; --- 4053,4059 ---- { Node_Id gnat_node; ! dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree)); for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++) dummy_node_table[gnat_node] = NULL_TREE; *************** elaborate_expression_1 (gnat_expr, gnat_ *** 4267,4282 **** int need_debug; { tree gnu_decl = 0; - tree gnu_inner_expr = gnu_expr; - int expr_variable; - int expr_global = Is_Public (gnat_entity) || global_bindings_p (); - /* Strip any conversions to see if the expression is a readonly variable. ??? This really should remain readonly, but we have to think about the typing of the tree here. */ ! while (TREE_CODE (gnu_inner_expr) == NOP_EXPR ! && TREE_CODE (gnu_inner_expr) == CONVERT_EXPR) ! gnu_inner_expr = TREE_OPERAND (gnu_inner_expr, 0); /* In most cases, we won't see a naked FIELD_DECL here because a discriminant reference will have been replaced with a COMPONENT_REF --- 4301,4312 ---- int need_debug; { tree gnu_decl = 0; /* Strip any conversions to see if the expression is a readonly variable. ??? This really should remain readonly, but we have to think about the typing of the tree here. */ ! tree gnu_inner_expr = remove_conversions (gnu_expr, 1); ! int expr_global = Is_Public (gnat_entity) || global_bindings_p (); ! int expr_variable; /* In most cases, we won't see a naked FIELD_DECL here because a discriminant reference will have been replaced with a COMPONENT_REF *************** elaborate_expression_1 (gnat_expr, gnat_ *** 4326,4331 **** --- 4356,4363 ---- can do the right thing in the local case. */ if (expr_global && expr_variable) return gnu_decl; + else if (! expr_variable) + return gnu_expr; else return maybe_variable (gnu_expr, gnat_expr); } *************** make_packable_type (type) *** 4418,4426 **** ! DECL_NONADDRESSABLE_P (old_field)); DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); ! DECL_ORIGINAL_FIELD (new_field) ! = (DECL_ORIGINAL_FIELD (old_field) != 0 ! ? DECL_ORIGINAL_FIELD (old_field) : old_field); TREE_CHAIN (new_field) = field_list; field_list = new_field; } --- 4450,4458 ---- ! DECL_NONADDRESSABLE_P (old_field)); DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); ! SET_DECL_ORIGINAL_FIELD (new_field, ! (DECL_ORIGINAL_FIELD (old_field) != 0 ! ? DECL_ORIGINAL_FIELD (old_field) : old_field)); TREE_CHAIN (new_field) = field_list; field_list = new_field; } *************** maybe_pad_type (type, size, align, gnat_ *** 4554,4560 **** /* Keep the RM_Size of the padded record as that of the old record if requested. */ ! TYPE_ADA_SIZE (record) = same_rm_size ? size : rm_size (type); /* Unless debugging information isn't being written for the input type, write a record that shows what we are a subtype of and also make a --- 4586,4592 ---- /* Keep the RM_Size of the padded record as that of the old record if requested. */ ! SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type)); /* Unless debugging information isn't being written for the input type, write a record that shows what we are a subtype of and also make a *************** gnat_to_gnu_field (gnat_field, gnu_recor *** 4757,4771 **** gnu_size = validate_size (Esize (gnat_field), gnu_field_type, gnat_field, FIELD_DECL, 0, 1); ! /* If we are packing this record and the field type is also a record that's BLKmode and with a small constant size, see if we can get a better form of the type that allows more packing. If we can, show a size was specified for it if there wasn't one so we know to make this a bitfield and avoid making things wider. */ ! if (packed && TREE_CODE (gnu_field_type) == RECORD_TYPE && TYPE_MODE (gnu_field_type) == BLKmode && host_integerp (TYPE_SIZE (gnu_field_type), 1) ! && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0) { gnu_field_type = make_packable_type (gnu_field_type); --- 4789,4814 ---- gnu_size = validate_size (Esize (gnat_field), gnu_field_type, gnat_field, FIELD_DECL, 0, 1); ! /* If the field's type is a left-justified modular type, make the field ! the type of the inner object unless it is aliases. We don't need ! the the wrapper here and it can prevent packing. */ ! if (! Is_Aliased (gnat_field) && TREE_CODE (gnu_field_type) == RECORD_TYPE ! && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type)) ! gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); ! ! /* If we are packing this record or we have a specified size that's ! smaller than that of the field type and the field type is also a record that's BLKmode and with a small constant size, see if we can get a better form of the type that allows more packing. If we can, show a size was specified for it if there wasn't one so we know to make this a bitfield and avoid making things wider. */ ! if (TREE_CODE (gnu_field_type) == RECORD_TYPE && TYPE_MODE (gnu_field_type) == BLKmode && host_integerp (TYPE_SIZE (gnu_field_type), 1) ! && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0 ! && (packed ! || (gnu_size != 0 && tree_int_cst_lt (gnu_size, ! TYPE_SIZE (gnu_field_type))))) { gnu_field_type = make_packable_type (gnu_field_type); *************** gnat_to_gnu_field (gnat_field, gnu_recor *** 4839,4845 **** if (Is_Aliased (gnat_field)) post_error_ne_num ("position of aliased field& must be multiple of ^ bits", ! Component_Clause (gnat_field), gnat_field, TYPE_ALIGN (gnu_field_type)); else if (Is_Volatile (gnat_field)) --- 4882,4888 ---- if (Is_Aliased (gnat_field)) post_error_ne_num ("position of aliased field& must be multiple of ^ bits", ! First_Bit (Component_Clause (gnat_field)), gnat_field, TYPE_ALIGN (gnu_field_type)); else if (Is_Volatile (gnat_field)) *************** gnat_to_gnu_field (gnat_field, gnu_recor *** 4897,4909 **** } /* We need to make the size the maximum for the type if it is ! self-referential and an unconstrained type. */ if (TREE_CODE (gnu_field_type) == RECORD_TYPE && gnu_size == 0 && ! TREE_CONSTANT (TYPE_SIZE (gnu_field_type)) && contains_placeholder_p (TYPE_SIZE (gnu_field_type)) && ! Is_Constrained (Underlying_Type (Etype (gnat_field)))) ! gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1); /* If no size is specified (or if there was an error), don't specify a position. */ --- 4940,4956 ---- } /* We need to make the size the maximum for the type if it is ! self-referential and an unconstrained type. In that case, we can't ! pack the field since we can't make a copy to align it. */ if (TREE_CODE (gnu_field_type) == RECORD_TYPE && gnu_size == 0 && ! TREE_CONSTANT (TYPE_SIZE (gnu_field_type)) && contains_placeholder_p (TYPE_SIZE (gnu_field_type)) && ! Is_Constrained (Underlying_Type (Etype (gnat_field)))) ! { ! gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1); ! packed = 0; ! } /* If no size is specified (or if there was an error), don't specify a position. */ *************** annotate_rep (gnat_entity, gnu_type) *** 5383,5389 **** (we can get the sizes easily at any time) by a recursive call and then update all the sizes into the tree. */ gnu_list = compute_field_positions (gnu_type, NULL_TREE, ! size_zero_node, bitsize_zero_node); for (gnat_field = First_Entity (gnat_entity); Present (gnat_field); gnat_field = Next_Entity (gnat_field)) --- 5430,5437 ---- (we can get the sizes easily at any time) by a recursive call and then update all the sizes into the tree. */ gnu_list = compute_field_positions (gnu_type, NULL_TREE, ! size_zero_node, bitsize_zero_node, ! BIGGEST_ALIGNMENT); for (gnat_field = First_Entity (gnat_entity); Present (gnat_field); gnat_field = Next_Entity (gnat_field)) *************** annotate_rep (gnat_entity, gnu_type) *** 5398,5422 **** (gnat_field, annotate_value (bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)), ! TREE_VALUE (TREE_VALUE (gnu_entry))))); Set_Esize (gnat_field, annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); } } ! /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is ! the FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the ! byte position and TREE_VALUE being the bit position. GNU_POS is to ! be added to the position, GNU_BITPOS to the bit position, and GNU_LIST ! is the entries so far. */ static tree ! compute_field_positions (gnu_type, gnu_list, gnu_pos, gnu_bitpos) tree gnu_type; tree gnu_list; tree gnu_pos; tree gnu_bitpos; { tree gnu_field; tree gnu_result = gnu_list; --- 5446,5474 ---- (gnat_field, annotate_value (bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)), ! TREE_VALUE (TREE_VALUE ! (TREE_VALUE (gnu_entry)))))); Set_Esize (gnat_field, annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); } } ! /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the ! FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte ! position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be ! placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is ! to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is ! the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries ! so far. */ static tree ! compute_field_positions (gnu_type, gnu_list, gnu_pos, gnu_bitpos, offset_align) tree gnu_type; tree gnu_list; tree gnu_pos; tree gnu_bitpos; + unsigned int offset_align; { tree gnu_field; tree gnu_result = gnu_list; *************** compute_field_positions (gnu_type, gnu_l *** 5426,5443 **** { tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, DECL_FIELD_BIT_OFFSET (gnu_field)); ! tree gnu_our_pos = size_binop (PLUS_EXPR, gnu_pos, ! DECL_FIELD_OFFSET (gnu_field)); gnu_result = tree_cons (gnu_field, ! tree_cons (gnu_our_pos, gnu_our_bitpos, NULL_TREE), gnu_result); if (DECL_INTERNAL_P (gnu_field)) gnu_result ! = compute_field_positions (TREE_TYPE (gnu_field), ! gnu_result, gnu_our_pos, gnu_our_bitpos); } return gnu_result; --- 5478,5501 ---- { tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, DECL_FIELD_BIT_OFFSET (gnu_field)); ! tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos, ! DECL_FIELD_OFFSET (gnu_field)); ! unsigned int our_offset_align ! = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field)); gnu_result = tree_cons (gnu_field, ! tree_cons (gnu_our_offset, ! tree_cons (size_int (our_offset_align), ! gnu_our_bitpos, NULL_TREE), ! NULL_TREE), gnu_result); if (DECL_INTERNAL_P (gnu_field)) gnu_result ! = compute_field_positions (TREE_TYPE (gnu_field), gnu_result, ! gnu_our_offset, gnu_our_bitpos, ! our_offset_align); } return gnu_result; *************** set_rm_size (uint_size, gnu_type, gnat_e *** 5641,5652 **** && Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) TYPE_RM_SIZE_INT (gnu_type) = size; else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE) ! TYPE_RM_SIZE_ENUM (gnu_type) = size; else if ((TREE_CODE (gnu_type) == RECORD_TYPE || TREE_CODE (gnu_type) == UNION_TYPE || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) && ! TYPE_IS_FAT_POINTER_P (gnu_type)) ! TYPE_ADA_SIZE (gnu_type) = size; } /* Given a type TYPE, return a new type whose size is appropriate for SIZE. --- 5699,5710 ---- && Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) TYPE_RM_SIZE_INT (gnu_type) = size; else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE) ! SET_TYPE_RM_SIZE_ENUM (gnu_type, size); else if ((TREE_CODE (gnu_type) == RECORD_TYPE || TREE_CODE (gnu_type) == UNION_TYPE || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) && ! TYPE_IS_FAT_POINTER_P (gnu_type)) ! SET_TYPE_ADA_SIZE (gnu_type, size); } /* Given a type TYPE, return a new type whose size is appropriate for SIZE. *************** validate_alignment (alignment, gnat_enti *** 5743,5748 **** --- 5801,5812 ---- if (Present (Alignment_Clause (gnat_entity))) gnat_error_node = Expression (Alignment_Clause (gnat_entity)); + /* Don't worry about checking alignment if alignment was not specified + by the source program and we already posted an error for this entity. */ + + if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity)) + return align; + /* Within GCC, an alignment is an integer, so we must make sure a value is specified that fits in that range. Also, alignments of more than MAX_OFILE_ALIGNMENT can't be supported. */ *************** gnat_substitute_in_type (t, f, r) *** 5874,5881 **** new = build_range_type (TREE_TYPE (t), low, high); if (TYPE_INDEX_TYPE (t)) ! TYPE_INDEX_TYPE (new) ! = gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r); return new; } --- 5938,5945 ---- new = build_range_type (TREE_TYPE (t), low, high); if (TYPE_INDEX_TYPE (t)) ! SET_TYPE_INDEX_TYPE (new, ! gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r)); return new; } *************** gnat_substitute_in_type (t, f, r) *** 5995,6003 **** } DECL_CONTEXT (new_field) = new; ! DECL_ORIGINAL_FIELD (new_field) ! = DECL_ORIGINAL_FIELD (field) != 0 ! ? DECL_ORIGINAL_FIELD (field) : field; /* If the size of the old field was set at a constant, propagate the size in case the type's size was variable. --- 6059,6067 ---- } DECL_CONTEXT (new_field) = new; ! SET_DECL_ORIGINAL_FIELD (new_field, ! (DECL_ORIGINAL_FIELD (field) != 0 ! ? DECL_ORIGINAL_FIELD (field) : field)); /* If the size of the old field was set at a constant, propagate the size in case the type's size was variable. *************** gnat_substitute_in_type (t, f, r) *** 6060,6066 **** { TYPE_SIZE (new) = TYPE_SIZE (t); TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t); ! TYPE_ADA_SIZE (new) = TYPE_ADA_SIZE (t); } return new; --- 6124,6130 ---- { TYPE_SIZE (new) = TYPE_SIZE (t); TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t); ! SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t)); } return new; *************** concat_id_with_name (gnu_id, suffix) *** 6148,6150 **** --- 6212,6216 ---- strcpy (Name_Buffer + len, suffix); return get_identifier (Name_Buffer); } + + #include "gt-ada-decl.h" diff -Nrc3pad gcc-3.2.3/gcc/ada/deftarg.c gcc-3.3/gcc/ada/deftarg.c *** gcc-3.2.3/gcc/ada/deftarg.c 2002-05-04 03:27:38.000000000 +0000 --- gcc-3.3/gcc/ada/deftarg.c 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * Body * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/directio.ads gcc-3.3/gcc/ada/directio.ads *** gcc-3.2.3/gcc/ada/directio.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/directio.ads 2002-03-14 10:59:07.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/einfo.adb gcc-3.3/gcc/ada/einfo.adb *** gcc-3.2.3/gcc/ada/einfo.adb 2002-05-04 03:27:38.000000000 +0000 --- gcc-3.3/gcc/ada/einfo.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.4.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Atree; use Atree; *** 40,46 **** with Namet; use Namet; with Nlists; use Nlists; with Sinfo; use Sinfo; - with Snames; use Snames; with Stand; use Stand; with Output; use Output; --- 39,44 ---- *************** package body Einfo is *** 181,188 **** -- Accept_Address Elist21 -- Default_Expr_Function Node21 -- Discriminant_Constraint Elist21 - -- Small_Value Ureal21 -- Interface_Name Node21 -- Associated_Storage_Pool Node22 -- Component_Size Uint22 --- 179,187 ---- -- Accept_Address Elist21 -- Default_Expr_Function Node21 -- Discriminant_Constraint Elist21 -- Interface_Name Node21 + -- Original_Array_Type Node21 + -- Small_Value Ureal21 -- Associated_Storage_Pool Node22 -- Component_Size Uint22 *************** package body Einfo is *** 395,402 **** -- Size_Depends_On_Discriminant Flag177 -- Is_Null_Init_Proc Flag178 -- Has_Pragma_Pure_Function Flag179 - -- (unused) Flag180 -- (unused) Flag181 -- (unused) Flag182 -- (unused) Flag183 --- 394,401 ---- -- Size_Depends_On_Discriminant Flag177 -- Is_Null_Init_Proc Flag178 -- Has_Pragma_Pure_Function Flag179 + -- Has_Pragma_Unreferenced Flag180 -- (unused) Flag181 -- (unused) Flag182 -- (unused) Flag183 *************** package body Einfo is *** 413,419 **** function Access_Disp_Table (Id : E) return E is begin pragma Assert (Is_Tagged_Type (Id)); ! return Node16 (Base_Type (Underlying_Type (Base_Type (Id)))); end Access_Disp_Table; function Actual_Subtype (Id : E) return E is --- 412,418 ---- function Access_Disp_Table (Id : E) return E is begin pragma Assert (Is_Tagged_Type (Id)); ! return Node16 (Implementation_Base_Type (Id)); end Access_Disp_Table; function Actual_Subtype (Id : E) return E is *************** package body Einfo is *** 463,469 **** function Associated_Storage_Pool (Id : E) return E is begin pragma Assert (Is_Access_Type (Id)); ! return Node22 (Id); end Associated_Storage_Pool; function Barrier_Function (Id : E) return N is --- 462,468 ---- function Associated_Storage_Pool (Id : E) return E is begin pragma Assert (Is_Access_Type (Id)); ! return Node22 (Root_Type (Id)); end Associated_Storage_Pool; function Barrier_Function (Id : E) return N is *************** package body Einfo is *** 1090,1095 **** --- 1089,1099 ---- return Flag179 (Id); end Has_Pragma_Pure_Function; + function Has_Pragma_Unreferenced (Id : E) return B is + begin + return Flag180 (Id); + end Has_Pragma_Unreferenced; + function Has_Primitive_Operations (Id : E) return B is begin pragma Assert (Is_Type (Id)); *************** package body Einfo is *** 1109,1115 **** function Has_Record_Rep_Clause (Id : E) return B is begin pragma Assert (Is_Record_Type (Id)); ! return Flag65 (Id); end Has_Record_Rep_Clause; function Has_Recursive_Call (Id : E) return B is --- 1113,1119 ---- function Has_Record_Rep_Clause (Id : E) return B is begin pragma Assert (Is_Record_Type (Id)); ! return Flag65 (Implementation_Base_Type (Id)); end Has_Record_Rep_Clause; function Has_Recursive_Call (Id : E) return B is *************** package body Einfo is *** 1131,1137 **** function Has_Specified_Layout (Id : E) return B is begin pragma Assert (Is_Type (Id)); ! return Flag100 (Id); end Has_Specified_Layout; function Has_Storage_Size_Clause (Id : E) return B is --- 1135,1141 ---- function Has_Specified_Layout (Id : E) return B is begin pragma Assert (Is_Type (Id)); ! return Flag100 (Implementation_Base_Type (Id)); end Has_Specified_Layout; function Has_Storage_Size_Clause (Id : E) return B is *************** package body Einfo is *** 1721,1726 **** --- 1725,1736 ---- return Node17 (Id); end Object_Ref; + function Original_Array_Type (Id : E) return E is + begin + pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id)); + return Node21 (Id); + end Original_Array_Type; + function Original_Record_Component (Id : E) return E is begin return Node22 (Id); *************** package body Einfo is *** 2241,2248 **** procedure Set_Access_Disp_Table (Id : E; V : E) is begin ! pragma Assert (Is_Tagged_Type (Id)); ! Set_Node16 (Base_Type (Id), V); end Set_Access_Disp_Table; procedure Set_Associated_Final_Chain (Id : E; V : E) is --- 2251,2258 ---- procedure Set_Access_Disp_Table (Id : E; V : E) is begin ! pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id)); ! Set_Node16 (Id, V); end Set_Access_Disp_Table; procedure Set_Associated_Final_Chain (Id : E; V : E) is *************** package body Einfo is *** 2263,2269 **** procedure Set_Associated_Storage_Pool (Id : E; V : E) is begin ! pragma Assert (Is_Access_Type (Id)); Set_Node22 (Id, V); end Set_Associated_Storage_Pool; --- 2273,2279 ---- procedure Set_Associated_Storage_Pool (Id : E; V : E) is begin ! pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); Set_Node22 (Id, V); end Set_Associated_Storage_Pool; *************** package body Einfo is *** 2349,2360 **** procedure Set_Component_Size (Id : E; V : U) is begin ! pragma Assert (Is_Array_Type (Id)); ! Set_Uint22 (Base_Type (Id), V); end Set_Component_Size; procedure Set_Component_Type (Id : E; V : E) is begin Set_Node20 (Id, V); end Set_Component_Type; --- 2359,2371 ---- procedure Set_Component_Size (Id : E; V : U) is begin ! pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id)); ! Set_Uint22 (Id, V); end Set_Component_Size; procedure Set_Component_Type (Id : E; V : E) is begin + pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id)); Set_Node20 (Id, V); end Set_Component_Type; *************** package body Einfo is *** 2669,2676 **** procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is begin ! pragma Assert (Is_Type (Id)); ! Set_Flag158 (Base_Type (Id), V); end Set_Finalize_Storage_Only; procedure Set_First_Entity (Id : E; V : E) is --- 2680,2687 ---- procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is begin ! pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); ! Set_Flag158 (Id, V); end Set_Finalize_Storage_Only; procedure Set_First_Entity (Id : E; V : E) is *************** package body Einfo is *** 2790,2803 **** procedure Set_Has_Complex_Representation (Id : E; V : B := True) is begin ! pragma Assert (Is_Record_Type (Id)); ! Set_Flag140 (Implementation_Base_Type (Id), V); end Set_Has_Complex_Representation; procedure Set_Has_Component_Size_Clause (Id : E; V : B := True) is begin ! pragma Assert (Is_Array_Type (Id)); ! Set_Flag68 (Implementation_Base_Type (Id), V); end Set_Has_Component_Size_Clause; procedure Set_Has_Controlled_Component (Id : E; V : B := True) is --- 2801,2814 ---- procedure Set_Has_Complex_Representation (Id : E; V : B := True) is begin ! pragma Assert (Ekind (Id) = E_Record_Type); ! Set_Flag140 (Id, V); end Set_Has_Complex_Representation; procedure Set_Has_Component_Size_Clause (Id : E; V : B := True) is begin ! pragma Assert (Ekind (Id) = E_Array_Type); ! Set_Flag68 (Id, V); end Set_Has_Component_Size_Clause; procedure Set_Has_Controlled_Component (Id : E; V : B := True) is *************** package body Einfo is *** 2924,2930 **** procedure Set_Has_Pragma_Pack (Id : E; V : B := True) is begin pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id)); ! Set_Flag121 (Implementation_Base_Type (Id), V); end Set_Has_Pragma_Pack; procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True) is --- 2935,2942 ---- procedure Set_Has_Pragma_Pack (Id : E; V : B := True) is begin pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id)); ! pragma Assert (Id = Base_Type (Id)); ! Set_Flag121 (Id, V); end Set_Has_Pragma_Pack; procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True) is *************** package body Einfo is *** 2933,2942 **** Set_Flag179 (Id, V); end Set_Has_Pragma_Pure_Function; procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is begin ! pragma Assert (Is_Type (Id)); ! Set_Flag120 (Base_Type (Id), V); end Set_Has_Primitive_Operations; procedure Set_Has_Private_Declaration (Id : E; V : B := True) is --- 2945,2959 ---- Set_Flag179 (Id, V); end Set_Has_Pragma_Pure_Function; + procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True) is + begin + Set_Flag180 (Id, V); + end Set_Has_Pragma_Unreferenced; + procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); ! Set_Flag120 (Id, V); end Set_Has_Primitive_Operations; procedure Set_Has_Private_Declaration (Id : E; V : B := True) is *************** package body Einfo is *** 2951,2957 **** procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is begin ! pragma Assert (Is_Record_Type (Id)); Set_Flag65 (Id, V); end Set_Has_Record_Rep_Clause; --- 2968,2974 ---- procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag65 (Id, V); end Set_Has_Record_Rep_Clause; *************** package body Einfo is *** 2973,2979 **** procedure Set_Has_Specified_Layout (Id : E; V : B := True) is begin ! pragma Assert (Is_Type (Id)); Set_Flag100 (Id, V); end Set_Has_Specified_Layout; --- 2990,2996 ---- procedure Set_Has_Specified_Layout (Id : E; V : B := True) is begin ! pragma Assert (Id = Base_Type (Id)); Set_Flag100 (Id, V); end Set_Has_Specified_Layout; *************** package body Einfo is *** 3087,3093 **** procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is begin ! Set_Flag122 (Implementation_Base_Type (Id), V); end Set_Is_Bit_Packed_Array; procedure Set_Is_Called (Id : E; V : B := True) is --- 3104,3113 ---- procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is begin ! pragma Assert ((not V) ! or else (Is_Array_Type (Id) and then Id = Base_Type (Id))); ! ! Set_Flag122 (Id, V); end Set_Is_Bit_Packed_Array; procedure Set_Is_Called (Id : E; V : B := True) is *************** package body Einfo is *** 3536,3542 **** procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin ! pragma Assert (Is_Access_Type (Id) and then Root_Type (Id) = Id); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; --- 3556,3562 ---- procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin ! pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; *************** package body Einfo is *** 3593,3598 **** --- 3613,3624 ---- Set_Node17 (Id, V); end Set_Object_Ref; + procedure Set_Original_Array_Type (Id : E; V : E) is + begin + pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id)); + Set_Node21 (Id, V); + end Set_Original_Array_Type; + procedure Set_Original_Record_Component (Id : E; V : E) is begin Set_Node22 (Id, V); *************** package body Einfo is *** 3861,3866 **** --- 3887,3893 ---- procedure Set_Suppress_Init_Proc (Id : E; V : B := True) is begin + pragma Assert (Id = Base_Type (Id)); Set_Flag105 (Id, V); end Set_Suppress_Init_Proc; *************** package body Einfo is *** 4055,4061 **** function Known_Alignment (E : Entity_Id) return B is begin ! return Uint14 (E) /= Uint_0; end Known_Alignment; function Known_Component_Bit_Offset (E : Entity_Id) return B is --- 4082,4089 ---- function Known_Alignment (E : Entity_Id) return B is begin ! return Uint14 (E) /= Uint_0 ! and then Uint14 (E) /= No_Uint; end Known_Alignment; function Known_Component_Bit_Offset (E : Entity_Id) return B is *************** package body Einfo is *** 4065,4076 **** function Known_Component_Size (E : Entity_Id) return B is begin ! return Uint22 (Base_Type (E)) /= Uint_0; end Known_Component_Size; function Known_Esize (E : Entity_Id) return B is begin ! return Uint12 (E) /= Uint_0; end Known_Esize; function Known_Normalized_First_Bit (E : Entity_Id) return B is --- 4093,4106 ---- function Known_Component_Size (E : Entity_Id) return B is begin ! return Uint22 (Base_Type (E)) /= Uint_0 ! and then Uint22 (Base_Type (E)) /= No_Uint; end Known_Component_Size; function Known_Esize (E : Entity_Id) return B is begin ! return Uint12 (E) /= Uint_0 ! and then Uint12 (E) /= No_Uint; end Known_Esize; function Known_Normalized_First_Bit (E : Entity_Id) return B is *************** package body Einfo is *** 4090,4097 **** function Known_RM_Size (E : Entity_Id) return B is begin ! return Uint13 (E) /= Uint_0 ! or else Is_Discrete_Type (E); end Known_RM_Size; function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is --- 4120,4128 ---- function Known_RM_Size (E : Entity_Id) return B is begin ! return Uint13 (E) /= No_Uint ! and then (Uint13 (E) /= Uint_0 ! or else Is_Discrete_Type (E)); end Known_RM_Size; function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is *************** package body Einfo is *** 4110,4115 **** --- 4141,4152 ---- return Uint12 (E) > Uint_0; end Known_Static_Esize; + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is + begin + return Uint8 (E) /= No_Uint + and then Uint8 (E) >= Uint_0; + end Known_Static_Normalized_First_Bit; + function Known_Static_Normalized_Position (E : Entity_Id) return B is begin return Uint9 (E) /= No_Uint *************** package body Einfo is *** 4130,4136 **** function Unknown_Alignment (E : Entity_Id) return B is begin ! return Uint14 (E) = Uint_0; end Unknown_Alignment; function Unknown_Component_Bit_Offset (E : Entity_Id) return B is --- 4167,4174 ---- function Unknown_Alignment (E : Entity_Id) return B is begin ! return Uint14 (E) = Uint_0 ! or else Uint14 (E) = No_Uint; end Unknown_Alignment; function Unknown_Component_Bit_Offset (E : Entity_Id) return B is *************** package body Einfo is *** 4140,4151 **** function Unknown_Component_Size (E : Entity_Id) return B is begin ! return Uint22 (Base_Type (E)) = Uint_0; end Unknown_Component_Size; function Unknown_Esize (E : Entity_Id) return B is begin ! return Uint12 (E) = Uint_0; end Unknown_Esize; function Unknown_Normalized_First_Bit (E : Entity_Id) return B is --- 4178,4193 ---- function Unknown_Component_Size (E : Entity_Id) return B is begin ! return Uint22 (Base_Type (E)) = Uint_0 ! or else ! Uint22 (Base_Type (E)) = No_Uint; end Unknown_Component_Size; function Unknown_Esize (E : Entity_Id) return B is begin ! return Uint12 (E) = No_Uint ! or else ! Uint12 (E) = Uint_0; end Unknown_Esize; function Unknown_Normalized_First_Bit (E : Entity_Id) return B is *************** package body Einfo is *** 4165,4172 **** function Unknown_RM_Size (E : Entity_Id) return B is begin ! return Uint13 (E) = Uint_0 ! and then not Is_Discrete_Type (E); end Unknown_RM_Size; -------------------- --- 4207,4215 ---- function Unknown_RM_Size (E : Entity_Id) return B is begin ! return (Uint13 (E) = Uint_0 ! and then not Is_Discrete_Type (E)) ! or else Uint13 (E) = No_Uint; end Unknown_RM_Size; -------------------- *************** package body Einfo is *** 4686,4691 **** --- 4729,4804 ---- end if; end First_Subtype; + ------------------------------------- + -- Get_Attribute_Definition_Clause -- + ------------------------------------- + + function Get_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) + return Node_Id + is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Attribute_Definition_Clause + and then Get_Attribute_Id (Chars (N)) = Id + then + return N; + else + Next_Rep_Item (N); + end if; + end loop; + + return Empty; + end Get_Attribute_Definition_Clause; + + -------------------- + -- Get_Rep_Pragma -- + -------------------- + + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is + N : Node_Id; + Typ : Entity_Id; + + begin + N := First_Rep_Item (E); + + while Present (N) loop + if Nkind (N) = N_Pragma and then Chars (N) = Nam then + + if Nam = Name_Stream_Convert then + + -- For tagged types this pragma is not inherited, so we + -- must verify that it is defined for the given type and + -- not an ancestor. + + Typ := Entity (Expression + (First (Pragma_Argument_Associations (N)))); + + if not Is_Tagged_Type (E) + or else E = Typ + or else (Is_Private_Type (Typ) + and then E = Full_View (Typ)) + then + return N; + else + Next_Rep_Item (N); + end if; + + else + return N; + end if; + else + Next_Rep_Item (N); + end if; + end loop; + + return Empty; + end Get_Rep_Pragma; + ------------------------ -- Has_Attach_Handler -- ------------------------ *************** package body Einfo is *** 4808,4814 **** -- happen in error situations and should avoid some error bombs. if Present (Imptyp) then ! return Imptyp; else return Bastyp; end if; --- 4921,4927 ---- -- happen in error situations and should avoid some error bombs. if Present (Imptyp) then ! return Base_Type (Imptyp); else return Bastyp; end if; *************** package body Einfo is *** 5845,5850 **** --- 5958,5964 ---- W ("Has_Pragma_Inline", Flag157 (Id)); W ("Has_Pragma_Pack", Flag121 (Id)); W ("Has_Pragma_Pure_Function", Flag179 (Id)); + W ("Has_Pragma_Unreferenced", Flag180 (Id)); W ("Has_Primitive_Operations", Flag120 (Id)); W ("Has_Private_Declaration", Flag155 (Id)); W ("Has_Qualified_Name", Flag161 (Id)); *************** package body Einfo is *** 6099,6104 **** --- 6213,6220 ---- ----------------------- procedure Write_Field6_Name (Id : Entity_Id) is + pragma Warnings (Off, Id); + begin Write_Str ("First_Rep_Item"); end Write_Field6_Name; *************** package body Einfo is *** 6108,6113 **** --- 6224,6231 ---- ----------------------- procedure Write_Field7_Name (Id : Entity_Id) is + pragma Warnings (Off, Id); + begin Write_Str ("Freeze_Node"); end Write_Field7_Name; *************** package body Einfo is *** 6124,6130 **** Write_Str ("Normalized_First_Bit"); when Formal_Kind | ! E_Function => Write_Str ("Mechanism"); when Type_Kind => --- 6242,6249 ---- Write_Str ("Normalized_First_Bit"); when Formal_Kind | ! E_Function | ! E_Subprogram_Body => Write_Str ("Mechanism"); when Type_Kind => *************** package body Einfo is *** 6686,6691 **** --- 6805,6814 ---- when E_In_Parameter => Write_Str ("Default_Expr_Function"); + when Array_Kind | + Modular_Integer_Kind => + Write_Str ("Original_Array_Type"); + when others => Write_Str ("Field21??"); end case; diff -Nrc3pad gcc-3.2.3/gcc/ada/einfo.ads gcc-3.3/gcc/ada/einfo.ads *** gcc-3.2.3/gcc/ada/einfo.ads 2002-05-04 03:27:39.000000000 +0000 --- gcc-3.3/gcc/ada/einfo.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.7.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** *** 33,38 **** --- 32,38 ---- -- -- ------------------------------------------------------------------------------ + with Snames; use Snames; with Types; use Types; with Uintp; use Uintp; with Urealp; use Urealp; *************** package Einfo is *** 270,286 **** -- are so noted by the notation [base type only]. These are cases where the -- attribute of any subtype is the same as the attribute of the base type. -- The attribute can be referenced on a subtype (and automatically retrieves ! -- the value from the base type), and if an attempt is made to set them on ! -- other than a subtype, they will instead be set on the corresponding base ! -- type. -- Other attributes are noted as applying the implementation base type only. -- These are representation attributes which must always apply to a full -- non-private type, and where the attributes are always on the full type. -- The attribute can be referenced on a subtype (and automatically retries ! -- the value from the implementation base type), and if an attempt is made ! -- to set them on other than a subtype, they will instead be set on the ! -- corresponding implementation base type. -- Accept_Address (Elist21) -- Present in entries. If an accept has a statement sequence, then an --- 270,287 ---- -- are so noted by the notation [base type only]. These are cases where the -- attribute of any subtype is the same as the attribute of the base type. -- The attribute can be referenced on a subtype (and automatically retrieves ! -- the value from the base type). However, it is an error to try to set the ! -- attribute on other than the base type, and if assertions are enabled, ! -- an attempt to set the attribute on a subtype will raise an assert error. -- Other attributes are noted as applying the implementation base type only. -- These are representation attributes which must always apply to a full -- non-private type, and where the attributes are always on the full type. -- The attribute can be referenced on a subtype (and automatically retries ! -- the value from the implementation base type). However, it is an error ! -- to try to set the attribute on other than the implementation base type, ! -- and if assertions are enabled, an attempt to set the attribute on a ! -- subtype will raise an assert error. -- Accept_Address (Elist21) -- Present in entries. If an accept has a statement sequence, then an *************** package Einfo is *** 309,315 **** -- rather irregular, and the semantic checks that depend on the nominal -- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv). ! -- Access_Disp_Table (Node16) [base type only] -- Present in record type entities. For a tagged type, points to the -- dispatch table associated with the tagged type. For a non-tagged -- record, contains Empty. --- 310,316 ---- -- rather irregular, and the semantic checks that depend on the nominal -- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv). ! -- Access_Disp_Table (Node16) [implementation base type only] -- Present in record type entities. For a tagged type, points to the -- dispatch table associated with the tagged type. For a non-tagged -- record, contains Empty. *************** package Einfo is *** 367,376 **** -- the node whose elaboration generated the Itype. This is used for -- copying trees, to determine whether or not to copy an Itype. ! -- Associated_Storage_Pool (Node22) -- Present in simple and general access type entities. References the -- storage pool to be used for the corresponding collection. A value of ! -- Empty means that the default pool is to be used. -- Associated_Final_Chain (Node23) -- Present in simple and general access type entities. References the --- 368,379 ---- -- the node whose elaboration generated the Itype. This is used for -- copying trees, to determine whether or not to copy an Itype. ! -- Associated_Storage_Pool (Node22) [root type only] -- Present in simple and general access type entities. References the -- storage pool to be used for the corresponding collection. A value of ! -- Empty means that the default pool is to be used. This is present ! -- only in the root type, since derived types must have the same pool ! -- as the parent type. -- Associated_Final_Chain (Node23) -- Present in simple and general access type entities. References the *************** package Einfo is *** 400,406 **** -- for finalization purposes, The block entity has an implicit label -- declaration in the enclosing declarative part, and has otherwise -- no direct connection in the tree with the block statement. The ! -- link is to the identifier (which is an occurrence of the entity) -- and not to the block_statement itself, because the statement may -- be rewritten, e.g. in the process of removing dead code. --- 403,409 ---- -- for finalization purposes, The block entity has an implicit label -- declaration in the enclosing declarative part, and has otherwise -- no direct connection in the tree with the block statement. The ! -- link is to the identifier (which is an occurence of the entity) -- and not to the block_statement itself, because the statement may -- be rewritten, e.g. in the process of removing dead code. *************** package Einfo is *** 511,519 **** -- for details of these values. -- Component_Type (Node20) [implementation base type only] ! -- Present in array types and subtypes, and also in the special ! -- enumeration table type created for enumeration type. References ! -- the entity for the component type. -- Constant_Value (synthesized) -- Applies to constants, named integers, and named reals. Obtains --- 514,520 ---- -- for details of these values. -- Component_Type (Node20) [implementation base type only] ! -- Present in array types and string types. References component type. -- Constant_Value (synthesized) -- Applies to constants, named integers, and named reals. Obtains *************** package Einfo is *** 1360,1368 **** -- Pure_Function was given for the entity. In some cases, we need to -- know that Is_Pure was explicitly set using this pragma. -- Has_Primitive_Operations (Flag120) [base type only] -- Present in all type entities. Set if at least one primitive operation ! -- is defined on the type. This flag is not yet properly set ??? -- Has_Private_Ancestor (synthesized) -- Applies to all type and subtype entities. Returns True if at least --- 1361,1375 ---- -- Pure_Function was given for the entity. In some cases, we need to -- know that Is_Pure was explicitly set using this pragma. + -- Has_Pragma_Unreferenced (Flag180) + -- Present in all entities. Set if a valid pragma Unreferenced applies + -- to the pragma, indicating that no warning should be given if the + -- entity has no references, but a warning should be given if it is + -- in fact referenced. + -- Has_Primitive_Operations (Flag120) [base type only] -- Present in all type entities. Set if at least one primitive operation ! -- is defined for the type. -- Has_Private_Ancestor (synthesized) -- Applies to all type and subtype entities. Returns True if at least *************** package Einfo is *** 1386,1392 **** -- the flag Has_Fully_Qualified_Name, which is set if the name does -- indeed include the fully qualified name. ! -- Has_Record_Rep_Clause (Flag65) -- Present in record types. Set if a record representation clause has -- been given for this record type. Used to prevent more than one such -- clause for a given record type. Note that this is initially cleared --- 1393,1399 ---- -- the flag Has_Fully_Qualified_Name, which is set if the name does -- indeed include the fully qualified name. ! -- Has_Record_Rep_Clause (Flag65) [implementation base type only] -- Present in record types. Set if a record representation clause has -- been given for this record type. Used to prevent more than one such -- clause for a given record type. Note that this is initially cleared *************** package Einfo is *** 1412,1418 **** -- initially cleared for a derived type, even though the Small for such -- a type is inherited from a Small clause given for the parent type. ! -- Has_Specified_Layout (Flag100) -- Present in all type entities. Set for a record type or subtype if -- the record layout has been specified by a record representation -- clause. Note that this differs from the flag Has_Record_Rep_Clause --- 1419,1425 ---- -- initially cleared for a derived type, even though the Small for such -- a type is inherited from a Small clause given for the parent type. ! -- Has_Specified_Layout (Flag100) [implementation base type only] -- Present in all type entities. Set for a record type or subtype if -- the record layout has been specified by a record representation -- clause. Note that this differs from the flag Has_Record_Rep_Clause *************** package Einfo is *** 1575,1581 **** -- Present in all type entities and in procedure entities. Set -- if a pragma Asynchronous applies to the entity. ! -- Is_Bit_Packed_Array (Flag122) -- Present in all entities. This flag is set for a packed array -- type that is bit packed (i.e. the component size is known by the -- front end and is in the range 1-7, 9-15, or 17-31). Is_Packed is --- 1582,1588 ---- -- Present in all type entities and in procedure entities. Set -- if a pragma Asynchronous applies to the entity. ! -- Is_Bit_Packed_Array (Flag122) [implementation base type only] -- Present in all entities. This flag is set for a packed array -- type that is bit packed (i.e. the component size is known by the -- front end and is in the range 1-7, 9-15, or 17-31). Is_Packed is *************** package Einfo is *** 1718,1724 **** -- Is_Eliminated (Flag124) -- Present in type entities, subprogram entities, and object entities. -- Indicates that the corresponding entity has been eliminated by use ! -- of pragma Eliminate. -- Is_Enumeration_Type (synthesized) -- Present in all entities, true for enumeration types and subtypes --- 1725,1732 ---- -- Is_Eliminated (Flag124) -- Present in type entities, subprogram entities, and object entities. -- Indicates that the corresponding entity has been eliminated by use ! -- of pragma Eliminate. Also used to mark subprogram entities whose ! -- declaration and body are within unreachable code that is removed. -- Is_Enumeration_Type (synthesized) -- Present in all entities, true for enumeration types and subtypes *************** package Einfo is *** 2012,2018 **** -- if the type appears in the Packed_Array_Type field of some other type -- entity. It is used by Gigi to activate the special processing for such -- types (unchecked conversions that would not otherwise be allowed are ! -- allowed for such types). -- Is_Potentially_Use_Visible (Flag9) -- Present in all entities. Set if entity is potentially use visible, --- 2020,2028 ---- -- if the type appears in the Packed_Array_Type field of some other type -- entity. It is used by Gigi to activate the special processing for such -- types (unchecked conversions that would not otherwise be allowed are ! -- allowed for such types). If the Is_Packed_Array_Type flag is set in ! -- an entity, then the Original_Array_Type field of this entity points ! -- to the original array type for which this is the packed array type. -- Is_Potentially_Use_Visible (Flag9) -- Present in all entities. Set if entity is potentially use visible, *************** package Einfo is *** 2251,2257 **** -- Mechanism (Uint8) (returned as Mechanism_Type) -- Present in functions and non-generic formal parameters. Indicates -- the mechanism to be used for the function return or for the formal ! -- parameter. See separate section on passing mechanisms. -- Modulus (Uint17) [base type only] -- Present in modular types. Contains the modulus. For the binary --- 2261,2269 ---- -- Mechanism (Uint8) (returned as Mechanism_Type) -- Present in functions and non-generic formal parameters. Indicates -- the mechanism to be used for the function return or for the formal ! -- parameter. See separate section on passing mechanisms. This field ! -- is also set (to the default value of zero) in a subprogram body ! -- entity but not used in this context. -- Modulus (Uint17) [base type only] -- Present in modular types. Contains the modulus. For the binary *************** package Einfo is *** 2382,2388 **** -- Present in access types. Set if a storage size clause applies to -- the variable with a compile time known value of zero. This flag is -- used to generate warnings if any attempt is made to allocate an ! -- instance of such an access type. -- No_Return (Flag113) -- Present in procedure and generic procedure entries. Indicates that --- 2394,2401 ---- -- Present in access types. Set if a storage size clause applies to -- the variable with a compile time known value of zero. This flag is -- used to generate warnings if any attempt is made to allocate an ! -- instance of such an access type. This is set only in the root ! -- type, since derived types must have the same pool. -- No_Return (Flag113) -- Present in procedure and generic procedure entries. Indicates that *************** package Einfo is *** 2426,2431 **** --- 2439,2451 ---- -- Applies to subprograms and subprogram types. Yields the number of -- formals as a value of type Pos. + -- Original_Array_Type (Node21) + -- Present in modular types and array types and subtypes. Set only + -- if the Is_Packed_Array_Type flag is set, indicating that the type + -- is the implementation type for a packed array, and in this case it + -- points to the original array type for which this is the packed + -- array implementation type. + -- Object_Ref (Node17) -- Present in protected bodies. This is an implicit prival for the -- Protection object associated with a protected object. See Prival *************** package Einfo is *** 2466,2472 **** -- Parameter_Mode (synthesized) -- Applies to formal parameter entities. This is a synonym for Ekind, -- used when obtaining the formal kind of a formal parameter (the result ! -- is one of E_[In/Out/In_Out]_Parameter) -- Parent_Subtype (Node19) -- Present in E_Record_Type. Points to the subtype to use for a --- 2486,2492 ---- -- Parameter_Mode (synthesized) -- Applies to formal parameter entities. This is a synonym for Ekind, -- used when obtaining the formal kind of a formal parameter (the result ! -- is one of E_[In/Out/In_Out]_Paramter) -- Parent_Subtype (Node19) -- Present in E_Record_Type. Points to the subtype to use for a *************** package Einfo is *** 2616,2622 **** -- returns the result by reference, either because its return typ is a -- by-reference-type or because it uses explicitly the secondary stack. ! -- Reverse_Bit_Order (Flag164) -- Present in all record type entities. Set if a valid pragma an -- attribute represention clause for Bit_Order has reversed the order -- of bits from the default value. When this flag is set, a component --- 2636,2642 ---- -- returns the result by reference, either because its return typ is a -- by-reference-type or because it uses explicitly the secondary stack. ! -- Reverse_Bit_Order (Flag164) [base type only] -- Present in all record type entities. Set if a valid pragma an -- attribute represention clause for Bit_Order has reversed the order -- of bits from the default value. When this flag is set, a component *************** package Einfo is *** 3668,3677 **** -- Has_Homonym (Flag56) -- Has_Pragma_Elaborate_Body (Flag150) -- Has_Pragma_Inline (Flag157) -- Has_Private_Declaration (Flag155) -- Has_Qualified_Name (Flag161) -- Has_Unknown_Discriminants (Flag72) ! -- Is_Bit_Packed_Array (Flag122) -- Is_Child_Unit (Flag73) -- Is_Compilation_Unit (Flag149) -- Is_Completely_Hidden (Flag103) --- 3688,3698 ---- -- Has_Homonym (Flag56) -- Has_Pragma_Elaborate_Body (Flag150) -- Has_Pragma_Inline (Flag157) + -- Has_Pragma_Unreferenced (Flag180) -- Has_Private_Declaration (Flag155) -- Has_Qualified_Name (Flag161) -- Has_Unknown_Discriminants (Flag72) ! -- Is_Bit_Packed_Array (Flag122) (base type only) -- Is_Child_Unit (Flag73) -- Is_Compilation_Unit (Flag149) -- Is_Completely_Hidden (Flag103) *************** package Einfo is *** 3745,3756 **** -- Discard_Names (Flag88) -- Finalize_Storage_Only (Flag158) (base type only) -- From_With_Type (Flag159) ! -- Has_Aliased_Components (Flag135) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) (base type only) -- Has_Complex_Representation (Flag140) (base type only) -- Has_Discriminants (Flag5) ! -- Has_Non_Standard_Rep (Flag75) -- Has_Object_Size_Clause (Flag172) -- Has_Primitive_Operations (Flag120) (base type only) -- Has_Size_Clause (Flag29) --- 3766,3777 ---- -- Discard_Names (Flag88) -- Finalize_Storage_Only (Flag158) (base type only) -- From_With_Type (Flag159) ! -- Has_Aliased_Components (Flag135) (base type only) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) (base type only) -- Has_Complex_Representation (Flag140) (base type only) -- Has_Discriminants (Flag5) ! -- Has_Non_Standard_Rep (Flag75) (base type only) -- Has_Object_Size_Clause (Flag172) -- Has_Primitive_Operations (Flag120) (base type only) -- Has_Size_Clause (Flag29) *************** package Einfo is *** 3778,3784 **** -- Is_Volatile (Flag16) -- Size_Depends_On_Discriminant (Flag177) -- Size_Known_At_Compile_Time (Flag92) ! -- Strict_Alignment (Flag145) -- Suppress_Init_Proc (Flag105) (base type only) -- Alignment_Clause (synth) --- 3799,3805 ---- -- Is_Volatile (Flag16) -- Size_Depends_On_Discriminant (Flag177) -- Size_Known_At_Compile_Time (Flag92) ! -- Strict_Alignment (Flag145) (base type only) -- Suppress_Init_Proc (Flag105) (base type only) -- Alignment_Clause (synth) *************** package Einfo is *** 3811,3825 **** -- E_Access_Type -- E_Access_Subtype ! -- Storage_Size_Variable (Node15) (root type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) ! -- Associated_Storage_Pool (Node22) -- Associated_Final_Chain (Node23) -- Has_Pragma_Controlled (Flag27) (base type only) ! -- Has_Storage_Size_Clause (Flag23) (root type only) -- Is_Access_Constant (Flag69) ! -- No_Pool_Assigned (Flag131) (root type only) -- (plus type attributes) -- E_Access_Attribute_Type --- 3832,3846 ---- -- E_Access_Type -- E_Access_Subtype ! -- Storage_Size_Variable (Node15) (base type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) ! -- Associated_Storage_Pool (Node22) (base type only) -- Associated_Final_Chain (Node23) -- Has_Pragma_Controlled (Flag27) (base type only) ! -- Has_Storage_Size_Clause (Flag23) (base type only) -- Is_Access_Constant (Flag69) ! -- No_Pool_Assigned (Flag131) (base type only) -- (plus type attributes) -- E_Access_Attribute_Type *************** package Einfo is *** 3840,3845 **** --- 3861,3867 ---- -- First_Index (Node17) -- Related_Array_Object (Node19) -- Component_Type (Node20) (base type only) + -- Original_Array_Type (Node21) -- Component_Size (Uint22) (base type only) -- Packed_Array_Type (Node23) -- Component_Alignment (special) (base type only) *************** package Einfo is *** 4089,4095 **** -- Storage_Size_Variable (Node15) (base type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) ! -- Associated_Storage_Pool (Node22) -- Associated_Final_Chain (Node23) -- (plus type attributes) --- 4111,4117 ---- -- Storage_Size_Variable (Node15) (base type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) ! -- Associated_Storage_Pool (Node22) (base type only) -- Associated_Final_Chain (Node23) -- (plus type attributes) *************** package Einfo is *** 4163,4168 **** --- 4185,4191 ---- -- E_Modular_Integer_Type -- E_Modular_Integer_Subtype -- Modulus (Uint17) (base type only) + -- Original_Array_Type (Node21) -- Scalar_Range (Node20) -- Non_Binary_Modulus (Flag58) (base type only) -- Has_Biased_Representation (Flag139) *************** package Einfo is *** 4352,4364 **** -- Parent_Subtype (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) ! -- Corresponding_Remote_Type (Node22) (base type only) -- Girder_Constraint (Elist23) -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (Flag125) (base type only) -- Has_Controlled_Component (Flag43) (base type only) -- Has_External_Tag_Rep_Clause (Flag110) ! -- Has_Record_Rep_Clause (Flag65) -- Is_Concurrent_Record_Type (Flag20) -- Is_Constrained (Flag12) -- Is_Controlled (Flag42) (base type only) --- 4375,4387 ---- -- Parent_Subtype (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) ! -- Corresponding_Remote_Type (Node22) -- Girder_Constraint (Elist23) -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (Flag125) (base type only) -- Has_Controlled_Component (Flag43) (base type only) -- Has_External_Tag_Rep_Clause (Flag110) ! -- Has_Record_Rep_Clause (Flag65) (base type only) -- Is_Concurrent_Record_Type (Flag20) -- Is_Constrained (Flag12) -- Is_Controlled (Flag42) (base type only) *************** package Einfo is *** 4383,4389 **** -- Has_Completion (Flag26) -- Has_Completion_In_Body (Flag71) -- Has_Controlled_Component (Flag43) (base type only) ! -- Has_Record_Rep_Clause (Flag65) -- Has_External_Tag_Rep_Clause (Flag110) -- Is_Concurrent_Record_Type (Flag20) -- Is_Constrained (Flag12) --- 4406,4412 ---- -- Has_Completion (Flag26) -- Has_Completion_In_Body (Flag71) -- Has_Controlled_Component (Flag43) (base type only) ! -- Has_Record_Rep_Clause (Flag65) (base type only) -- Has_External_Tag_Rep_Clause (Flag110) -- Is_Concurrent_Record_Type (Flag20) -- Is_Constrained (Flag12) *************** package Einfo is *** 4416,4426 **** -- String_Literal_Low_Bound (Node15) -- String_Literal_Length (Uint16) -- First_Index (Node17) (always Empty) - -- Component_Type (Node20) (base type only) -- Packed_Array_Type (Node23) -- (plus type attributes) -- E_Subprogram_Body -- First_Entity (Node17) -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) --- 4439,4449 ---- -- String_Literal_Low_Bound (Node15) -- String_Literal_Length (Uint16) -- First_Index (Node17) (always Empty) -- Packed_Array_Type (Node23) -- (plus type attributes) -- E_Subprogram_Body + -- Mechanism (Uint8) -- First_Entity (Node17) -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) *************** package Einfo is *** 4845,4850 **** --- 4868,4874 ---- function Has_Pragma_Inline (Id : E) return B; function Has_Pragma_Pack (Id : E) return B; function Has_Pragma_Pure_Function (Id : E) return B; + function Has_Pragma_Unreferenced (Id : E) return B; function Has_Primitive_Operations (Id : E) return B; function Has_Qualified_Name (Id : E) return B; function Has_Record_Rep_Clause (Id : E) return B; *************** package Einfo is *** 4955,4960 **** --- 4979,4985 ---- function Normalized_Position_Max (Id : E) return U; function Not_Source_Assigned (Id : E) return B; function Object_Ref (Id : E) return E; + function Original_Array_Type (Id : E) return E; function Original_Record_Component (Id : E) return E; function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; *************** package Einfo is *** 5137,5151 **** -- possible, so we do not need a separate Known_Static calls in -- these cases. The not set (unknown values are as follows: ! -- Alignment Uint_0 ! -- Component_Size Uint_0 -- Component_Bit_Offset No_Uint ! -- Digits_Value Uint_0 ! -- Esize Uint_0 -- Normalized_First_Bit No_Uint -- Normalized_Position No_Uint -- Normalized_Position_Max No_Uint ! -- RM_Size Uint_0 -- It would be cleaner to use No_Uint in all these cases, but historically -- we chose to use Uint_0 at first, and the change over will take time ??? --- 5162,5176 ---- -- possible, so we do not need a separate Known_Static calls in -- these cases. The not set (unknown values are as follows: ! -- Alignment Uint_0 or No_Uint ! -- Component_Size Uint_0 or No_Uint -- Component_Bit_Offset No_Uint ! -- Digits_Value Uint_0 or No_Uint ! -- Esize Uint_0 or No_Uint -- Normalized_First_Bit No_Uint -- Normalized_Position No_Uint -- Normalized_Position_Max No_Uint ! -- RM_Size Uint_0 or No_Uint -- It would be cleaner to use No_Uint in all these cases, but historically -- we chose to use Uint_0 at first, and the change over will take time ??? *************** package Einfo is *** 5166,5171 **** --- 5191,5197 ---- function Known_Static_Component_Bit_Offset (E : Entity_Id) return B; function Known_Static_Component_Size (E : Entity_Id) return B; function Known_Static_Esize (E : Entity_Id) return B; + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B; function Known_Static_Normalized_Position (E : Entity_Id) return B; function Known_Static_Normalized_Position_Max (E : Entity_Id) return B; function Known_Static_RM_Size (E : Entity_Id) return B; *************** package Einfo is *** 5301,5306 **** --- 5327,5333 ---- procedure Set_Has_Pragma_Inline (Id : E; V : B := True); procedure Set_Has_Pragma_Pack (Id : E; V : B := True); procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True); + procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True); procedure Set_Has_Primitive_Operations (Id : E; V : B := True); procedure Set_Has_Private_Declaration (Id : E; V : B := True); procedure Set_Has_Qualified_Name (Id : E; V : B := True); *************** package Einfo is *** 5416,5421 **** --- 5443,5449 ---- procedure Set_Normalized_Position_Max (Id : E; V : U); procedure Set_Not_Source_Assigned (Id : E; V : B := True); procedure Set_Object_Ref (Id : E; V : E); + procedure Set_Original_Array_Type (Id : E; V : E); procedure Set_Original_Record_Component (Id : E; V : E); procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); *************** package Einfo is *** 5590,5595 **** --- 5618,5637 ---- procedure Append_Entity (Id : Entity_Id; V : Entity_Id); -- Add an entity to the list of entities declared in the scope V + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; + -- Searches the Rep_Item chain for the given entity E, for an instance + -- of a representation pragma with the given name Nam. If found then + -- the value returned is the N_Pragma node, otherwise Empty is returned. + + function Get_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) + return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance + -- of an attribute definition clause with the given attibute Id Id. If + -- found, the value returned is the N_Attribute_Definition_Clause node, + -- otherwise Empty is returned. + function Is_Entity_Name (N : Node_Id) return Boolean; -- Test if the node N is the name of an entity (i.e. is an identifier, -- expanded name, or an attribute reference that returns an entity). *************** package Einfo is *** 5769,5774 **** --- 5811,5817 ---- pragma Inline (Has_Pragma_Inline); pragma Inline (Has_Pragma_Pack); pragma Inline (Has_Pragma_Pure_Function); + pragma Inline (Has_Pragma_Unreferenced); pragma Inline (Has_Primitive_Operations); pragma Inline (Has_Private_Declaration); pragma Inline (Has_Qualified_Name); *************** package Einfo is *** 5920,5925 **** --- 5963,5969 ---- pragma Inline (Normalized_Position_Max); pragma Inline (Not_Source_Assigned); pragma Inline (Object_Ref); + pragma Inline (Original_Array_Type); pragma Inline (Original_Record_Component); pragma Inline (Packed_Array_Type); pragma Inline (Parameter_Mode); *************** package Einfo is *** 5988,6006 **** pragma Inline (Init_Esize); pragma Inline (Init_RM_Size); - pragma Inline (Known_Alignment); - pragma Inline (Known_Component_Bit_Offset); - pragma Inline (Known_Component_Size); - pragma Inline (Known_Esize); - - pragma Inline (Known_Static_Component_Size); - pragma Inline (Known_Static_Esize); - - pragma Inline (Unknown_Alignment); - pragma Inline (Unknown_Component_Bit_Offset); - pragma Inline (Unknown_Component_Size); - pragma Inline (Unknown_Esize); - pragma Inline (Set_Accept_Address); pragma Inline (Set_Access_Disp_Table); pragma Inline (Set_Actual_Subtype); --- 6032,6037 ---- *************** package Einfo is *** 6115,6120 **** --- 6146,6152 ---- pragma Inline (Set_Has_Pragma_Inline); pragma Inline (Set_Has_Pragma_Pack); pragma Inline (Set_Has_Pragma_Pure_Function); + pragma Inline (Set_Has_Pragma_Unreferenced); pragma Inline (Set_Has_Primitive_Operations); pragma Inline (Set_Has_Private_Declaration); pragma Inline (Set_Has_Qualified_Name); *************** package Einfo is *** 6230,6235 **** --- 6262,6268 ---- pragma Inline (Set_Normalized_Position_Max); pragma Inline (Set_Not_Source_Assigned); pragma Inline (Set_Object_Ref); + pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Record_Component); pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); diff -Nrc3pad gcc-3.2.3/gcc/ada/einfo.h gcc-3.3/gcc/ada/einfo.h *** gcc-3.2.3/gcc/ada/einfo.h 2003-04-22 06:56:18.000000000 +0000 --- gcc-3.3/gcc/ada/einfo.h 2003-05-14 00:18:14.000000000 +0000 *************** *** 6,16 **** /* */ /* C Header File */ /* */ ! /* Generated by xeinfo revision 1.2 using */ ! /* einfo.ads revision 1.7 */ ! /* einfo.adb revision 1.4 */ /* */ ! /* 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,16 ---- /* */ /* C Header File */ /* */ ! /* Generated by xeinfo revision 1.3 using */ ! /* einfo.ads revision 1.654 */ ! /* einfo.adb revision 1.642 */ /* */ ! /* 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- */ *************** *** 361,366 **** --- 361,367 ---- INLINE B Has_Pragma_Inline (E Id); INLINE B Has_Pragma_Pack (E Id); INLINE B Has_Pragma_Pure_Function (E Id); + INLINE B Has_Pragma_Unreferenced (E Id); INLINE B Has_Primitive_Operations (E Id); INLINE B Has_Qualified_Name (E Id); INLINE B Has_Record_Rep_Clause (E Id); *************** *** 474,479 **** --- 475,481 ---- INLINE U Normalized_Position_Max (E Id); INLINE B Not_Source_Assigned (E Id); INLINE E Object_Ref (E Id); + INLINE E Original_Array_Type (E Id); INLINE E Original_Record_Component (E Id); INLINE E Packed_Array_Type (E Id); INLINE E Parent_Subtype (E Id); *************** *** 723,732 **** #define Underlying_Type einfo__underlying_type E Underlying_Type (E Id); ! INLINE B Known_Alignment (Entity_Id E); ! INLINE B Known_Component_Bit_Offset (Entity_Id E); ! INLINE B Known_Component_Size (Entity_Id E); ! INLINE B Known_Esize (Entity_Id E); #define Known_Normalized_First_Bit einfo__known_normalized_first_bit B Known_Normalized_First_Bit (Entity_Id E); --- 725,741 ---- #define Underlying_Type einfo__underlying_type E Underlying_Type (E Id); ! #define Known_Alignment einfo__known_alignment ! B Known_Alignment (Entity_Id E); ! ! #define Known_Component_Bit_Offset einfo__known_component_bit_offset ! B Known_Component_Bit_Offset (Entity_Id E); ! ! #define Known_Component_Size einfo__known_component_size ! B Known_Component_Size (Entity_Id E); ! ! #define Known_Esize einfo__known_esize ! B Known_Esize (Entity_Id E); #define Known_Normalized_First_Bit einfo__known_normalized_first_bit B Known_Normalized_First_Bit (Entity_Id E); *************** *** 743,750 **** #define Known_Static_Component_Bit_Offset einfo__known_static_component_bit_offset B Known_Static_Component_Bit_Offset (Entity_Id E); ! INLINE B Known_Static_Component_Size (Entity_Id E); ! INLINE B Known_Static_Esize (Entity_Id E); #define Known_Static_Normalized_Position einfo__known_static_normalized_position B Known_Static_Normalized_Position (Entity_Id E); --- 752,765 ---- #define Known_Static_Component_Bit_Offset einfo__known_static_component_bit_offset B Known_Static_Component_Bit_Offset (Entity_Id E); ! #define Known_Static_Component_Size einfo__known_static_component_size ! B Known_Static_Component_Size (Entity_Id E); ! ! #define Known_Static_Esize einfo__known_static_esize ! B Known_Static_Esize (Entity_Id E); ! ! #define Known_Static_Normalized_First_Bit einfo__known_static_normalized_first_bit ! B Known_Static_Normalized_First_Bit (Entity_Id E); #define Known_Static_Normalized_Position einfo__known_static_normalized_position B Known_Static_Normalized_Position (Entity_Id E); *************** *** 755,764 **** #define Known_Static_RM_Size einfo__known_static_rm_size B Known_Static_RM_Size (Entity_Id E); ! INLINE B Unknown_Alignment (Entity_Id E); ! INLINE B Unknown_Component_Bit_Offset (Entity_Id E); ! INLINE B Unknown_Component_Size (Entity_Id E); ! INLINE B Unknown_Esize (Entity_Id E); #define Unknown_Normalized_First_Bit einfo__unknown_normalized_first_bit B Unknown_Normalized_First_Bit (Entity_Id E); --- 770,786 ---- #define Known_Static_RM_Size einfo__known_static_rm_size B Known_Static_RM_Size (Entity_Id E); ! #define Unknown_Alignment einfo__unknown_alignment ! B Unknown_Alignment (Entity_Id E); ! ! #define Unknown_Component_Bit_Offset einfo__unknown_component_bit_offset ! B Unknown_Component_Bit_Offset (Entity_Id E); ! ! #define Unknown_Component_Size einfo__unknown_component_size ! B Unknown_Component_Size (Entity_Id E); ! ! #define Unknown_Esize einfo__unknown_esize ! B Unknown_Esize (Entity_Id E); #define Unknown_Normalized_First_Bit einfo__unknown_normalized_first_bit B Unknown_Normalized_First_Bit (Entity_Id E); *************** *** 777,783 **** { return Elist21 (Id); } INLINE E Access_Disp_Table (E Id) ! { return Node16 (Base_Type (Underlying_Type (Base_Type (Id)))); } INLINE E Actual_Subtype (E Id) { return Node17 (Id); } --- 799,805 ---- { return Elist21 (Id); } INLINE E Access_Disp_Table (E Id) ! { return Node16 (Implementation_Base_Type (Id)); } INLINE E Actual_Subtype (E Id) { return Node17 (Id); } *************** *** 801,807 **** { return Node8 (Id); } INLINE E Associated_Storage_Pool (E Id) ! { return Node22 (Id); } INLINE N Barrier_Function (E Id) { return Node12 (Id); } --- 823,829 ---- { return Node8 (Id); } INLINE E Associated_Storage_Pool (E Id) ! { return Node22 (Root_Type (Id)); } INLINE N Barrier_Function (E Id) { return Node12 (Id); } *************** *** 1121,1126 **** --- 1143,1151 ---- INLINE B Has_Pragma_Pure_Function (E Id) { return Flag179 (Id); } + INLINE B Has_Pragma_Unreferenced (E Id) + { return Flag180 (Id); } + INLINE B Has_Primitive_Operations (E Id) { return Flag120 (Base_Type (Id)); } *************** *** 1131,1137 **** { return Flag161 (Id); } INLINE B Has_Record_Rep_Clause (E Id) ! { return Flag65 (Id); } INLINE B Has_Recursive_Call (E Id) { return Flag143 (Id); } --- 1156,1162 ---- { return Flag161 (Id); } INLINE B Has_Record_Rep_Clause (E Id) ! { return Flag65 (Implementation_Base_Type (Id)); } INLINE B Has_Recursive_Call (E Id) { return Flag143 (Id); } *************** *** 1143,1149 **** { return Flag67 (Id); } INLINE B Has_Specified_Layout (E Id) ! { return Flag100 (Id); } INLINE B Has_Storage_Size_Clause (E Id) { return Flag23 (Implementation_Base_Type (Id)); } --- 1168,1174 ---- { return Flag67 (Id); } INLINE B Has_Specified_Layout (E Id) ! { return Flag100 (Implementation_Base_Type (Id)); } INLINE B Has_Storage_Size_Clause (E Id) { return Flag23 (Implementation_Base_Type (Id)); } *************** *** 1463,1468 **** --- 1488,1496 ---- INLINE E Object_Ref (E Id) { return Node17 (Id); } + INLINE E Original_Array_Type (E Id) + { return Node21 (Id); } + INLINE E Original_Record_Component (E Id) { return Node22 (Id); } *************** *** 1745,1780 **** INLINE B Is_Type (E Id) { return IN (Ekind (Id), Type_Kind); } - INLINE B Known_Alignment (Entity_Id E) - { return Uint14 (E) != Uint_0; } - - INLINE B Known_Component_Bit_Offset (Entity_Id E) - { return Uint11 (E) != No_Uint; } - - INLINE B Known_Component_Size (Entity_Id E) - { return Uint22 (Base_Type (E)) != Uint_0; } - - INLINE B Known_Esize (Entity_Id E) - { return Uint12 (E) != Uint_0; } - - INLINE B Known_Static_Component_Size (Entity_Id E) - { return Uint22 (Base_Type (E)) > Uint_0; } - - INLINE B Known_Static_Esize (Entity_Id E) - { return Uint12 (E) > Uint_0; } - - INLINE B Unknown_Alignment (Entity_Id E) - { return Uint14 (E) == Uint_0; } - - INLINE B Unknown_Component_Bit_Offset (Entity_Id E) - { return Uint11 (E) == No_Uint; } - - INLINE B Unknown_Component_Size (Entity_Id E) - { return Uint22 (Base_Type (E)) == Uint_0; } - - INLINE B Unknown_Esize (Entity_Id E) - { return Uint12 (E) == Uint_0; } - INLINE N Entry_Index_Type (E Id) { return Etype (Discrete_Subtype_Definition (Parent (Id))); } --- 1773,1778 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/elists.adb gcc-3.3/gcc/ada/elists.adb *** gcc-3.2.3/gcc/ada/elists.adb 2002-05-04 03:27:40.000000000 +0000 --- gcc-3.3/gcc/ada/elists.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/elists.ads gcc-3.3/gcc/ada/elists.ads *** gcc-3.2.3/gcc/ada/elists.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/elists.ads 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/elists.h gcc-3.3/gcc/ada/elists.h *** gcc-3.2.3/gcc/ada/elists.h 2002-05-04 03:27:41.000000000 +0000 --- gcc-3.3/gcc/ada/elists.h 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * C Header File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- *************** struct Elmt_Item *** 51,59 **** /* The element list headers and element descriptors themselves are stored in two arrays. The pointers to these arrays are passed as a parameter to the tree transformer procedure and stored in the global variables Elists_Ptr ! and Elmts_Ptr after adjusting them by subtracting Elist_First_Entry and ! Elmt_First_Entry, so that Elist_Id and Elmt_Id values can be used as ! subscripts into these arrays */ extern struct Elist_Header *Elists_Ptr; extern struct Elmt_Item *Elmts_Ptr; --- 50,56 ---- /* The element list headers and element descriptors themselves are stored in two arrays. The pointers to these arrays are passed as a parameter to the tree transformer procedure and stored in the global variables Elists_Ptr ! and Elmts_Ptr. */ extern struct Elist_Header *Elists_Ptr; extern struct Elmt_Item *Elmts_Ptr; *************** INLINE Node_Id *** 70,97 **** Node (Elmt) Elmt_Id Elmt; { ! return Elmts_Ptr [Elmt].node; } INLINE Elmt_Id First_Elmt (List) Elist_Id List; { ! return Elists_Ptr [List].first; } INLINE Elmt_Id Last_Elmt (List) Elist_Id List; { ! return Elists_Ptr [List].last; } INLINE Elmt_Id Next_Elmt (Node) Elmt_Id Node; { ! Int N = Elmts_Ptr [Node].next; if (IN (N, Elist_Range)) return No_Elmt; --- 67,94 ---- Node (Elmt) Elmt_Id Elmt; { ! return Elmts_Ptr[Elmt - First_Elmt_Id].node; } INLINE Elmt_Id First_Elmt (List) Elist_Id List; { ! return Elists_Ptr[List - First_Elist_Id].first; } INLINE Elmt_Id Last_Elmt (List) Elist_Id List; { ! return Elists_Ptr[List - First_Elist_Id].last; } INLINE Elmt_Id Next_Elmt (Node) Elmt_Id Node; { ! Int N = Elmts_Ptr[Node - First_Elmt_Id].next; if (IN (N, Elist_Range)) return No_Elmt; *************** INLINE Boolean *** 103,107 **** Is_Empty_Elmt_List (Id) Elist_Id Id; { ! return Elists_Ptr [Id].first == No_Elmt; } --- 100,104 ---- Is_Empty_Elmt_List (Id) Elist_Id Id; { ! return Elists_Ptr[Id - First_Elist_Id].first == No_Elmt; } diff -Nrc3pad gcc-3.2.3/gcc/ada/errno.c gcc-3.3/gcc/ada/errno.c *** gcc-3.2.3/gcc/ada/errno.c 2002-05-04 03:27:41.000000000 +0000 --- gcc-3.3/gcc/ada/errno.c 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,12 **** * * * C Implementation File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/errout.adb gcc-3.3/gcc/ada/errout.adb *** gcc-3.2.3/gcc/ada/errout.adb 2002-05-04 03:27:41.000000000 +0000 --- gcc-3.3/gcc/ada/errout.adb 2002-10-23 07:33:22.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.5.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Hostparm; *** 42,47 **** --- 41,47 ---- with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; + with Nlists; use Nlists; with Output; use Output; with Scans; use Scans; with Sinput; use Sinput; *************** package body Errout is *** 72,77 **** --- 72,80 ---- Is_Warning_Msg : Boolean; -- Set by Set_Msg_Text to indicate if current message is warning message + Is_Serious_Error : Boolean; + -- Set by Set_Msg_Text to indicate if current message is serious error + Is_Unconditional_Msg : Boolean; -- Set by Set_Msg_Text to indicate if current message is unconditional *************** package body Errout is *** 161,166 **** --- 164,172 ---- Warn : Boolean; -- True if warning message (i.e. insertion character ? appeared) + Serious : Boolean; + -- True if serious error message (not a warning and no | character) + Uncond : Boolean; -- True if unconditional message (i.e. insertion character ! appeared) *************** package body Errout is *** 399,404 **** --- 405,422 ---- -- Outputs up to N levels of qualification for the given entity. For -- example, the entity A.B.C.D will output B.C. if N = 2. + function Special_Msg_Delete + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) + return Boolean; + -- This function is called from Error_Msg_NEL, passing the message Msg, + -- node N on which the error is to be posted, and the entity or node E + -- to be used for an & insertion in the message if any. The job of this + -- procedure is to test for certain cascaded messages that we would like + -- to suppress. If the message is to be suppressed then we return True. + -- If the message should be generated (the normal case) False is returned. + procedure Test_Warning_Msg (Msg : String); -- Sets Is_Warning_Msg true if Msg is a warning message (contains a -- question mark character), and False otherwise. *************** package body Errout is *** 506,511 **** --- 524,533 ---- -- always know that Keep has at least as many continuations as -- Delete (since we always delete the shorter sequence). + ---------------- + -- Delete_Msg -- + ---------------- + procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is D, K : Error_Msg_Id; *************** package body Errout is *** 521,527 **** if Errors.Table (D).Warn then Warnings_Detected := Warnings_Detected - 1; else ! Errors_Detected := Errors_Detected - 1; end if; -- Substitute shorter of the two error messages --- 543,553 ---- if Errors.Table (D).Warn then Warnings_Detected := Warnings_Detected - 1; else ! Total_Errors_Detected := Total_Errors_Detected - 1; ! ! if Errors.Table (D).Serious then ! Serious_Errors_Detected := Serious_Errors_Detected - 1; ! end if; end if; -- Substitute shorter of the two error messages *************** package body Errout is *** 602,608 **** function Compilation_Errors return Boolean is begin ! return Errors_Detected /= 0 or else (Warnings_Detected /= 0 and then Warning_Mode = Treat_As_Error); end Compilation_Errors; --- 628,634 ---- function Compilation_Errors return Boolean is begin ! return Total_Errors_Detected /= 0 or else (Warnings_Detected /= 0 and then Warning_Mode = Treat_As_Error); end Compilation_Errors; *************** package body Errout is *** 647,652 **** --- 673,679 ---- w (" Line = ", Int (E.Line)); w (" Col = ", Int (E.Col)); w (" Warn = ", E.Warn); + w (" Serious = ", E.Serious); w (" Uncond = ", E.Uncond); w (" Msg_Cont = ", E.Msg_Cont); w (" Deleted = ", E.Deleted); *************** package body Errout is *** 679,685 **** -- that this is safe in the sense that proceeding will surely bomb. if Flag_Location < First_Source_Ptr ! and then Errors_Detected > 0 then return; end if; --- 706,712 ---- -- that this is safe in the sense that proceeding will surely bomb. if Flag_Location < First_Source_Ptr ! and then Total_Errors_Detected > 0 then return; end if; *************** package body Errout is *** 976,986 **** Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location); ! procedure Handle_Fatal_Error; ! -- Internal procedure to do all error message handling other than ! -- bumping the error count and arranging for the message to be output. ! procedure Handle_Fatal_Error is begin -- Turn off code generation if not done already --- 1003,1018 ---- Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location); ! procedure Handle_Serious_Error; ! -- Internal procedure to do all error message handling for a serious ! -- error message, other than bumping the error counts and arranging ! -- for the message to be output. ! -------------------------- ! -- Handle_Serious_Error -- ! -------------------------- ! ! procedure Handle_Serious_Error is begin -- Turn off code generation if not done already *************** package body Errout is *** 991,997 **** -- Set the fatal error flag in the unit table unless we are -- in Try_Semantics mode. This stops the semantics from being ! -- performed if we find a parser error. This is skipped if we -- are currently dealing with the configuration pragma file. if not Try_Semantics --- 1023,1029 ---- -- Set the fatal error flag in the unit table unless we are -- in Try_Semantics mode. This stops the semantics from being ! -- performed if we find a serious error. This is skipped if we -- are currently dealing with the configuration pragma file. if not Try_Semantics *************** package body Errout is *** 999,1005 **** then Set_Fatal_Error (Get_Source_Unit (Orig_Loc)); end if; ! end Handle_Fatal_Error; -- Start of processing for Error_Msg_Internal --- 1031,1037 ---- then Set_Fatal_Error (Get_Source_Unit (Orig_Loc)); end if; ! end Handle_Serious_Error; -- Start of processing for Error_Msg_Internal *************** package body Errout is *** 1039,1045 **** if Kill_Message and then not All_Errors_Mode ! and then Errors_Detected /= 0 then if not Continuation then Last_Killed := True; --- 1071,1077 ---- if Kill_Message and then not All_Errors_Mode ! and then Total_Errors_Detected /= 0 then if not Continuation then Last_Killed := True; *************** package body Errout is *** 1059,1065 **** -- where we do this special processing, bypassing message output. if Ignore_Errors_Enable > 0 then ! Handle_Fatal_Error; return; end if; --- 1091,1100 ---- -- where we do this special processing, bypassing message output. if Ignore_Errors_Enable > 0 then ! if Is_Serious_Error then ! Handle_Serious_Error; ! end if; ! return; end if; *************** package body Errout is *** 1075,1080 **** --- 1110,1116 ---- Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Orig_Loc); Errors.Table (Cur_Msg).Col := Get_Column_Number (Orig_Loc); Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; + Errors.Table (Cur_Msg).Serious := Is_Serious_Error; Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; Errors.Table (Cur_Msg).Msg_Cont := Continuation; Errors.Table (Cur_Msg).Deleted := False; *************** package body Errout is *** 1181,1193 **** if Errors.Table (Cur_Msg).Warn then Warnings_Detected := Warnings_Detected + 1; else ! Errors_Detected := Errors_Detected + 1; ! Handle_Fatal_Error; end if; -- Terminate if max errors reached ! if Errors_Detected + Warnings_Detected = Maximum_Errors then raise Unrecoverable_Error; end if; --- 1217,1233 ---- if Errors.Table (Cur_Msg).Warn then Warnings_Detected := Warnings_Detected + 1; else ! Total_Errors_Detected := Total_Errors_Detected + 1; ! ! if Errors.Table (Cur_Msg).Serious then ! Serious_Errors_Detected := Serious_Errors_Detected + 1; ! Handle_Serious_Error; ! end if; end if; -- Terminate if max errors reached ! if Total_Errors_Detected + Warnings_Detected = Maximum_Errors then raise Unrecoverable_Error; end if; *************** package body Errout is *** 1199,1228 **** procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is begin ! if No_Warnings (N) then ! Test_Warning_Msg (Msg); ! ! if Is_Warning_Msg then ! return; ! end if; ! end if; ! ! if All_Errors_Mode ! or else Msg (Msg'Last) = '!' ! or else OK_Node (N) ! or else (Msg (1) = '\' and not Last_Killed) ! then ! Debug_Output (N); ! Error_Msg_Node_1 := N; ! Error_Msg (Msg, Sloc (N)); ! ! else ! Last_Killed := True; ! end if; ! ! if not Is_Warning_Msg then ! Set_Posted (N); ! end if; end Error_Msg_N; ------------------ --- 1239,1245 ---- procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is begin ! Error_Msg_NEL (Msg, N, N, Sloc (N)); end Error_Msg_N; ------------------ *************** package body Errout is *** 1235,1240 **** --- 1252,1275 ---- E : Node_Or_Entity_Id) is begin + Error_Msg_NEL (Msg, N, E, Sloc (N)); + end Error_Msg_NE; + + ------------------- + -- Error_Msg_NEL -- + ------------------- + + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Location : Source_Ptr) + is + begin + if Special_Msg_Delete (Msg, N, E) then + return; + end if; + if No_Warnings (N) or else No_Warnings (E) then Test_Warning_Msg (Msg); *************** package body Errout is *** 1250,1256 **** then Debug_Output (N); Error_Msg_Node_1 := E; ! Error_Msg (Msg, Sloc (N)); else Last_Killed := True; --- 1285,1291 ---- then Debug_Output (N); Error_Msg_Node_1 := E; ! Error_Msg (Msg, Flag_Location); else Last_Killed := True; *************** package body Errout is *** 1259,1265 **** if not Is_Warning_Msg then Set_Posted (N); end if; ! end Error_Msg_NE; ----------------- -- Error_Msg_S -- --- 1294,1300 ---- if not Is_Warning_Msg then Set_Posted (N); end if; ! end Error_Msg_NEL; ----------------- -- Error_Msg_S -- *************** package body Errout is *** 1431,1437 **** -- Extra blank line if error messages or source listing were output ! if Errors_Detected + Warnings_Detected > 0 or else Full_List then Write_Eol; end if; --- 1466,1474 ---- -- Extra blank line if error messages or source listing were output ! if Total_Errors_Detected + Warnings_Detected > 0 ! or else Full_List ! then Write_Eol; end if; *************** package body Errout is *** 1447,1453 **** -- the stdout buffer was flushed, giving an extra line feed after -- the prefix. ! if Errors_Detected + Warnings_Detected /= 0 and then not Brief_Output and then (Verbose_Mode or Full_List) then --- 1484,1490 ---- -- the stdout buffer was flushed, giving an extra line feed after -- the prefix. ! if Total_Errors_Detected + Warnings_Detected /= 0 and then not Brief_Output and then (Verbose_Mode or Full_List) then *************** package body Errout is *** 1465,1478 **** Write_Str (" lines: "); end if; ! if Errors_Detected = 0 then Write_Str ("No errors"); ! elsif Errors_Detected = 1 then Write_Str ("1 error"); else ! Write_Int (Errors_Detected); Write_Str (" errors"); end if; --- 1502,1515 ---- Write_Str (" lines: "); end if; ! if Total_Errors_Detected = 0 then Write_Str ("No errors"); ! elsif Total_Errors_Detected = 1 then Write_Str ("1 error"); else ! Write_Int (Total_Errors_Detected); Write_Str (" errors"); end if; *************** package body Errout is *** 1501,1507 **** end if; if Maximum_Errors /= 0 ! and then Errors_Detected + Warnings_Detected = Maximum_Errors then Set_Standard_Error; Write_Str ("fatal error: maximum errors reached"); --- 1538,1544 ---- end if; if Maximum_Errors /= 0 ! and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors then Set_Standard_Error; Write_Str ("fatal error: maximum errors reached"); *************** package body Errout is *** 1510,1516 **** end if; if Warning_Mode = Treat_As_Error then ! Errors_Detected := Errors_Detected + Warnings_Detected; Warnings_Detected := 0; end if; --- 1547,1553 ---- end if; if Warning_Mode = Treat_As_Error then ! Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; Warnings_Detected := 0; end if; *************** package body Errout is *** 1542,1548 **** begin Errors.Init; Error_Msgs := No_Error_Msg; ! Errors_Detected := 0; Warnings_Detected := 0; Cur_Msg := No_Error_Msg; List_Pragmas.Init; --- 1579,1586 ---- begin Errors.Init; Error_Msgs := No_Error_Msg; ! Serious_Errors_Detected := 0; ! Total_Errors_Detected := 0; Warnings_Detected := 0; Cur_Msg := No_Error_Msg; List_Pragmas.Init; *************** package body Errout is *** 1907,1913 **** if Errors.Table (E).Warn then Warnings_Detected := Warnings_Detected - 1; else ! Errors_Detected := Errors_Detected - 1; end if; return True; --- 1945,1955 ---- if Errors.Table (E).Warn then Warnings_Detected := Warnings_Detected - 1; else ! Total_Errors_Detected := Total_Errors_Detected - 1; ! ! if Errors.Table (E).Serious then ! Serious_Errors_Detected := Serious_Errors_Detected - 1; ! end if; end if; return True; *************** package body Errout is *** 1996,2016 **** if Nkind (N) = N_Raise_Constraint_Error and then Original_Node (N) /= N then -- Warnings may have been posted on subexpressions of ! -- the original tree. We temporarily replace the raise ! -- statement with the original expression to remove ! -- those warnings, whose sloc do not match those of ! -- any node in the current tree. declare - Old : Node_Id := N; Status : Traverse_Result; begin ! Rewrite (N, Original_Node (N)); ! Status := Check_For_Warning (N); ! Rewrite (N, Old); return Status; end; --- 2038,2064 ---- if Nkind (N) = N_Raise_Constraint_Error and then Original_Node (N) /= N + and then No (Condition (N)) then -- Warnings may have been posted on subexpressions of ! -- the original tree. We place the original node back ! -- on the tree to remove those warnings, whose sloc ! -- do not match those of any node in the current tree. ! -- Given that we are in unreachable code, this modification ! -- to the tree is harmless. declare Status : Traverse_Result; begin ! if Is_List_Member (N) then ! Set_Condition (N, Original_Node (N)); ! Status := Check_All_Warnings (Condition (N)); ! else ! Rewrite (N, Original_Node (N)); ! Status := Check_All_Warnings (N); ! end if; ! return Status; end; *************** package body Errout is *** 2825,2830 **** --- 2873,2881 ---- elsif C = '?' then null; + elsif C = '|' then + null; + elsif C = ''' then Set_Msg_Char (Text (P)); P := P + 1; *************** package body Errout is *** 2887,2892 **** --- 2938,2954 ---- Set_Error_Posted (P); exit when Nkind (P) not in N_Subexpr; end loop; + + -- A special check, if we just posted an error on an attribute + -- definition clause, then also set the entity involved as posted. + -- For example, this stops complaining about the alignment after + -- complaining about the size, which is likely to be useless. + + if Nkind (P) = N_Attribute_Definition_Clause then + if Is_Entity_Name (Name (P)) then + Set_Error_Posted (Entity (Name (P))); + end if; + end if; end Set_Posted; ----------------------- *************** package body Errout is *** 2963,2977 **** end if; end Set_Warnings_Mode_On; ! ---------------------- ! -- Test_Warning_Msg -- ! ---------------------- procedure Test_Warning_Msg (Msg : String) is begin if Msg'Length > 7 and then Msg (1 .. 7) = "(style)" then Is_Warning_Msg := True; ! return; end if; for J in Msg'Range loop --- 3025,3102 ---- end if; end Set_Warnings_Mode_On; ! ------------------------ ! -- Special_Msg_Delete -- ! ------------------------ ! ! function Special_Msg_Delete ! (Msg : String; ! N : Node_Or_Entity_Id; ! E : Node_Or_Entity_Id) ! return Boolean ! is ! begin ! -- Never delete messages in -gnatdO mode ! ! if Debug_Flag_OO then ! return False; ! ! -- When an atomic object refers to a non-atomic type in the same ! -- scope, we implicitly make the type atomic. In the non-error ! -- case this is surely safe (and in fact prevents an error from ! -- occurring if the type is not atomic by default). But if the ! -- object cannot be made atomic, then we introduce an extra junk ! -- message by this manipulation, which we get rid of here. ! ! -- We identify this case by the fact that it references a type for ! -- which Is_Atomic is set, but there is no Atomic pragma setting it. ! ! elsif Msg = "atomic access to & cannot be guaranteed" ! and then Is_Type (E) ! and then Is_Atomic (E) ! and then No (Get_Rep_Pragma (E, Name_Atomic)) ! then ! return True; ! ! -- When a size is wrong for a frozen type there is no explicit ! -- size clause, and other errors have occurred, suppress the ! -- message, since it is likely that this size error is a cascaded ! -- result of other errors. The reason we eliminate unfrozen types ! -- is that messages issued before the freeze type are for sure OK. ! ! elsif Msg = "size for& too small, minimum allowed is ^" ! and then Is_Frozen (E) ! and then Serious_Errors_Detected > 0 ! and then Nkind (N) /= N_Component_Clause ! and then Nkind (Parent (N)) /= N_Component_Clause ! and then ! No (Get_Attribute_Definition_Clause (E, Attribute_Size)) ! and then ! No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size)) ! and then ! No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size)) ! then ! return True; ! ! -- All special tests complete, so go ahead with message ! ! else ! return False; ! end if; ! end Special_Msg_Delete; ! ! ------------------------------ ! -- Test_Warning_Serious_Msg -- ! ------------------------------ procedure Test_Warning_Msg (Msg : String) is begin + Is_Serious_Error := True; + if Msg'Length > 7 and then Msg (1 .. 7) = "(style)" then Is_Warning_Msg := True; ! else ! Is_Warning_Msg := False; end if; for J in Msg'Range loop *************** package body Errout is *** 2979,2989 **** and then (J = Msg'First or else Msg (J - 1) /= ''') then Is_Warning_Msg := True; ! return; end if; end loop; ! Is_Warning_Msg := False; end Test_Warning_Msg; -------------------------- --- 3104,3120 ---- and then (J = Msg'First or else Msg (J - 1) /= ''') then Is_Warning_Msg := True; ! ! elsif Msg (J) = '|' ! and then (J = Msg'First or else Msg (J - 1) /= ''') ! then ! Is_Serious_Error := False; end if; end loop; ! if Is_Warning_Msg then ! Is_Serious_Error := False; ! end if; end Test_Warning_Msg; -------------------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/errout.ads gcc-3.3/gcc/ada/errout.ads *** gcc-3.2.3/gcc/ada/errout.ads 2002-05-04 03:27:41.000000000 +0000 --- gcc-3.3/gcc/ada/errout.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** with Uintp; use Uintp; *** 37,44 **** package Errout is ! Errors_Detected : Nat; ! -- Number of errors detected so far Warnings_Detected : Nat; -- Number of warnings detected --- 36,50 ---- package Errout is ! Serious_Errors_Detected : Nat; ! -- This is a count of errors that are serious enough to stop expansion, ! -- and hence to prevent generation of an object file even if the ! -- switch -gnatQ is set. ! ! Total_Errors_Detected : Nat; ! -- Number of errors detected so far. Includes count of serious errors ! -- and non-serious errors, so this value is always greater than or ! -- equal to the Serious_Errors_Detected value. Warnings_Detected : Nat; -- Number of warnings detected *************** package Errout is *** 242,247 **** --- 248,261 ---- -- of messages are treated as a unit. The \ character must be -- the first character of the message text. + -- Insertion character | (vertical bar, non-serious error) + -- By default, error messages (other than warning messages) are + -- considered to be fatal error messages which prevent expansion + -- or generation of code in the presence of the -gnatQ switch. + -- If the insertion character | appears, the message is considered + -- to be non-serious, and does not cause Serious_Errors_Detected + -- to be incremented (so expansion is not prevented by such a msg). + ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- ----------------------------------------------------- *************** package Errout is *** 462,478 **** -- from the latter is much more common (and is the most usual way of -- generating error messages from the analyzer). The message text may -- contain a single & insertion, which will reference the given node. procedure Error_Msg_NE (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id); ! -- Output a message at the Sloc of the given node, with an insertion of ! -- the name from the given entity node. This is used by the semantic -- routines, where this is a common error message situation. The Msg -- text will contain a & or } as usual to mark the insertion point. -- This routine can be called from the parser or the analyzer. procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String); -- The error message text of the message identified by Id is replaced by -- the given text. This text may contain insertion characters in the --- 476,503 ---- -- from the latter is much more common (and is the most usual way of -- generating error messages from the analyzer). The message text may -- contain a single & insertion, which will reference the given node. + -- The message is suppressed if the node N already has a message posted, + -- or if it is a warning and warnings and N is an entity node for which + -- warnings are suppressed. procedure Error_Msg_NE (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id); ! -- Output a message at the Sloc of the given node N, with an insertion of ! -- the name from the given entity node E. This is used by the semantic -- routines, where this is a common error message situation. The Msg -- text will contain a & or } as usual to mark the insertion point. -- This routine can be called from the parser or the analyzer. + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Location : Source_Ptr); + -- Exactly the same as Error_Msg_NE, except that the flag is placed at + -- the specified Flag_Location instead of at Sloc (N). + procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String); -- The error message text of the message identified by Id is replaced by -- the given text. This text may contain insertion characters in the diff -Nrc3pad gcc-3.2.3/gcc/ada/eval_fat.adb gcc-3.3/gcc/ada/eval_fat.adb *** gcc-3.2.3/gcc/ada/eval_fat.adb 2002-05-04 03:27:42.000000000 +0000 --- gcc-3.3/gcc/ada/eval_fat.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Eval_Fat is *** 145,150 **** --- 144,150 ---- --------------- function Copy_Sign (RT : R; Value, Sign : T) return T is + pragma Warnings (Off, RT); Result : T; begin *************** package body Eval_Fat is *** 838,843 **** --- 838,845 ---- ------------- function Scaling (RT : R; X : T; Adjustment : UI) return T is + pragma Warnings (Off, RT); + begin if Rbase (X) = Radix then return UR_From_Components *************** package body Eval_Fat is *** 894,899 **** --- 896,903 ---- ---------------- function Truncation (RT : R; X : T) return T is + pragma Warnings (Off, RT); + begin return UR_From_Uint (UR_Trunc (X)); end Truncation; diff -Nrc3pad gcc-3.2.3/gcc/ada/eval_fat.ads gcc-3.3/gcc/ada/eval_fat.ads *** gcc-3.2.3/gcc/ada/eval_fat.ads 2002-05-04 03:27:43.000000000 +0000 --- gcc-3.3/gcc/ada/eval_fat.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exit.c gcc-3.3/gcc/ada/exit.c *** gcc-3.2.3/gcc/ada/exit.c 2002-05-04 03:27:43.000000000 +0000 --- gcc-3.3/gcc/ada/exit.c 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** * * * C Implementation File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_aggr.adb gcc-3.3/gcc/ada/exp_aggr.adb *** gcc-3.2.3/gcc/ada/exp_aggr.adb 2002-05-04 03:27:43.000000000 +0000 --- gcc-3.3/gcc/ada/exp_aggr.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.12.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** *** 28,33 **** --- 27,33 ---- with Atree; use Atree; with Checks; use Checks; + with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Expander; use Expander; *************** with Exp_Ch7; use Exp_Ch7; *** 37,46 **** --- 37,48 ---- with Freeze; use Freeze; with Hostparm; use Hostparm; with Itypes; use Itypes; + with Lib; use Lib; with Nmake; use Nmake; with Nlists; use Nlists; with Restrict; use Restrict; with Rtsfind; use Rtsfind; + with Ttypes; use Ttypes; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Eval; use Sem_Eval; *************** package body Exp_Aggr is *** 113,122 **** -- an entity that allows to know if the value being created needs to be -- attached to the final list in case of pragma finalize_Storage_Only. ----------------------------------------------------- ! -- Local subprograms for array aggregate expansion -- ----------------------------------------------------- procedure Expand_Array_Aggregate (N : Node_Id); -- This is the top-level routine to perform array aggregate expansion. -- N is the N_Aggregate node to be expanded. --- 115,155 ---- -- an entity that allows to know if the value being created needs to be -- attached to the final list in case of pragma finalize_Storage_Only. + procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id); + -- If the type of the aggregate is a type extension with renamed discrimi- + -- nants, we must initialize the hidden discriminants of the parent. + -- Otherwise, the target object must not be initialized. The discriminants + -- are initialized by calling the initialization procedure for the type. + -- This is incorrect if the initialization of other components has any + -- side effects. We restrict this call to the case where the parent type + -- has a variant part, because this is the only case where the hidden + -- discriminants are accessed, namely when calling discriminant checking + -- functions of the parent type, and when applying a stream attribute to + -- an object of the derived type. + ----------------------------------------------------- ! -- Local Subprograms for Array Aggregate Expansion -- ----------------------------------------------------- + procedure Convert_To_Positional + (N : Node_Id; + Max_Others_Replicate : Nat := 5; + Handle_Bit_Packed : Boolean := False); + -- If possible, convert named notation to positional notation. This + -- conversion is possible only in some static cases. If the conversion + -- is possible, then N is rewritten with the analyzed converted + -- aggregate. The parameter Max_Others_Replicate controls the maximum + -- number of values corresponding to an others choice that will be + -- converted to positional notation (the default of 5 is the normal + -- limit, and reflects the fact that normally the loop is better than + -- a lot of separate assignments). Note that this limit gets overridden + -- in any case if either of the restrictions No_Elaboration_Code or + -- No_Implicit_Loops is set. The parameter Handle_Bit_Packed is usually + -- set False (since we do not expect the back end to handle bit packed + -- arrays, so the normal case of conversion is pointless), but in the + -- special case of a call from Packed_Array_Aggregate_Handled, we set + -- this parameter to True, since these are cases we handle in there. + procedure Expand_Array_Aggregate (N : Node_Id); -- This is the top-level routine to perform array aggregate expansion. -- N is the N_Aggregate node to be expanded. *************** package body Exp_Aggr is *** 185,194 **** -- use this routine. This is needed to deal with assignments to -- initialized constants that are done in place. ! function Safe_Slice_Assignment ! (N : Node_Id; ! Typ : Entity_Id) ! return Boolean; -- If a slice assignment has an aggregate with a single others_choice, -- the assignment can be done in place even if bounds are not static, -- by converting it into a loop over the discrete range of the slice. --- 218,233 ---- -- use this routine. This is needed to deal with assignments to -- initialized constants that are done in place. ! function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; ! -- Given an array aggregate, this function handles the case of a packed ! -- array aggregate with all constant values, where the aggregate can be ! -- evaluated at compile time. If this is possible, then N is rewritten ! -- to be its proper compile time value with all the components properly ! -- assembled. The expression is analyzed and resolved and True is ! -- returned. If this transformation is not possible, N is unchanged ! -- and False is returned ! ! function Safe_Slice_Assignment (N : Node_Id) return Boolean; -- If a slice assignment has an aggregate with a single others_choice, -- the assignment can be done in place even if bounds are not static, -- by converting it into a loop over the discrete range of the slice. *************** package body Exp_Aggr is *** 340,349 **** -- we always generate something like: ! -- I : Index_Type := Index_Of_Last_Positional_Element; ! -- while I < H loop ! -- I := Index_Base'Succ (I) ! -- Tmp (I) := E; -- end loop; function Build_Array_Aggr_Code --- 379,388 ---- -- we always generate something like: ! -- J : Index_Type := Index_Of_Last_Positional_Element; ! -- while J < H loop ! -- J := Index_Base'Succ (J) ! -- Tmp (J) := E; -- end loop; function Build_Array_Aggr_Code *************** package body Exp_Aggr is *** 401,410 **** -- If the input aggregate N to Build_Loop contains no sub-aggregates, -- This routine returns the while loop statement -- ! -- I : Index_Base := L; ! -- while I < H loop ! -- I := Index_Base'Succ (I); ! -- Into (Indices, I) := Expr; -- end loop; -- -- Otherwise we call Build_Code recursively. --- 440,449 ---- -- If the input aggregate N to Build_Loop contains no sub-aggregates, -- This routine returns the while loop statement -- ! -- J : Index_Base := L; ! -- while J < H loop ! -- J := Index_Base'Succ (J); ! -- Into (Indices, J) := Expr; -- end loop; -- -- Otherwise we call Build_Code recursively. *************** package body Exp_Aggr is *** 788,800 **** -------------- function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is ! L_I : Node_Id; L_Range : Node_Id; -- Index_Base'(L) .. Index_Base'(H) L_Iteration_Scheme : Node_Id; ! -- L_I in Index_Base'(L) .. Index_Base'(H) L_Body : List_Id; -- The statements to execute in the loop --- 827,839 ---- -------------- function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is ! L_J : Node_Id; L_Range : Node_Id; -- Index_Base'(L) .. Index_Base'(H) L_Iteration_Scheme : Node_Id; ! -- L_J in Index_Base'(L) .. Index_Base'(H) L_Body : List_Id; -- The statements to execute in the loop *************** package body Exp_Aggr is *** 855,863 **** return S; end if; ! -- Otherwise construct the loop, starting with the loop index L_I ! L_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); -- Construct "L .. H" --- 894,902 ---- return S; end if; ! -- Otherwise construct the loop, starting with the loop index L_J ! L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); -- Construct "L .. H" *************** package body Exp_Aggr is *** 873,879 **** Subtype_Mark => Index_Base_Name, Expression => H)); ! -- Construct "for L_I in Index_Base range L .. H" L_Iteration_Scheme := Make_Iteration_Scheme --- 912,918 ---- Subtype_Mark => Index_Base_Name, Expression => H)); ! -- Construct "for L_J in Index_Base range L .. H" L_Iteration_Scheme := Make_Iteration_Scheme *************** package body Exp_Aggr is *** 881,892 **** Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, ! Defining_Identifier => L_I, Discrete_Subtype_Definition => L_Range)); -- Construct the statements to execute in the loop body ! L_Body := Gen_Assign (New_Reference_To (L_I, Loc), Expr); -- Construct the final loop --- 920,931 ---- Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, ! Defining_Identifier => L_J, Discrete_Subtype_Definition => L_Range)); -- Construct the statements to execute in the loop body ! L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr); -- Construct the final loop *************** package body Exp_Aggr is *** 905,931 **** -- The code built is ! -- W_I : Index_Base := L; ! -- while W_I < H loop ! -- W_I := Index_Base'Succ (W); -- L_Body; -- end loop; function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is ! W_I : Node_Id; W_Decl : Node_Id; ! -- W_I : Base_Type := L; W_Iteration_Scheme : Node_Id; ! -- while W_I < H W_Index_Succ : Node_Id; ! -- Index_Base'Succ (I) W_Increment : Node_Id; ! -- W_I := Index_Base'Succ (W) W_Body : List_Id := New_List; -- The statements to execute in the loop --- 944,970 ---- -- The code built is ! -- W_J : Index_Base := L; ! -- while W_J < H loop ! -- W_J := Index_Base'Succ (W); -- L_Body; -- end loop; function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is ! W_J : Node_Id; W_Decl : Node_Id; ! -- W_J : Base_Type := L; W_Iteration_Scheme : Node_Id; ! -- while W_J < H W_Index_Succ : Node_Id; ! -- Index_Base'Succ (J) W_Increment : Node_Id; ! -- W_J := Index_Base'Succ (W) W_Body : List_Id := New_List; -- The statements to execute in the loop *************** package body Exp_Aggr is *** 941,953 **** return S; end if; ! -- Build the decl of W_I ! W_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); W_Decl := Make_Object_Declaration (Loc, ! Defining_Identifier => W_I, Object_Definition => Index_Base_Name, Expression => L); --- 980,992 ---- return S; end if; ! -- Build the decl of W_J ! W_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); W_Decl := Make_Object_Declaration (Loc, ! Defining_Identifier => W_J, Object_Definition => Index_Base_Name, Expression => L); *************** package body Exp_Aggr is *** 957,970 **** Append_To (S, W_Decl); ! -- construct " while W_I < H" W_Iteration_Scheme := Make_Iteration_Scheme (Loc, Condition => Make_Op_Lt (Loc, ! Left_Opnd => New_Reference_To (W_I, Loc), Right_Opnd => New_Copy_Tree (H))); -- Construct the statements to execute in the loop body --- 996,1009 ---- Append_To (S, W_Decl); ! -- construct " while W_J < H" W_Iteration_Scheme := Make_Iteration_Scheme (Loc, Condition => Make_Op_Lt (Loc, ! Left_Opnd => New_Reference_To (W_J, Loc), Right_Opnd => New_Copy_Tree (H))); -- Construct the statements to execute in the loop body *************** package body Exp_Aggr is *** 974,990 **** (Loc, Prefix => Index_Base_Name, Attribute_Name => Name_Succ, ! Expressions => New_List (New_Reference_To (W_I, Loc))); W_Increment := Make_OK_Assignment_Statement (Loc, ! Name => New_Reference_To (W_I, Loc), Expression => W_Index_Succ); Append_To (W_Body, W_Increment); Append_List_To (W_Body, ! Gen_Assign (New_Reference_To (W_I, Loc), Expr)); -- Construct the final loop --- 1013,1029 ---- (Loc, Prefix => Index_Base_Name, Attribute_Name => Name_Succ, ! Expressions => New_List (New_Reference_To (W_J, Loc))); W_Increment := Make_OK_Assignment_Statement (Loc, ! Name => New_Reference_To (W_J, Loc), Expression => W_Index_Succ); Append_To (W_Body, W_Increment); Append_List_To (W_Body, ! Gen_Assign (New_Reference_To (W_J, Loc), Expr)); -- Construct the final loop *************** package body Exp_Aggr is *** 1417,1424 **** Selector_Name => New_Occurrence_Of (Discr, Loc)), Right_Opnd => Disc_Value); ! Append_To (L, Make_Raise_Constraint_Error (Loc, ! Condition => Cond)); end if; Next_Discriminant (Discr); --- 1456,1465 ---- Selector_Name => New_Occurrence_Of (Discr, Loc)), Right_Opnd => Disc_Value); ! Append_To (L, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Discriminant_Check_Failed)); end if; Next_Discriminant (Discr); *************** package body Exp_Aggr is *** 1556,1562 **** --- 1597,1606 ---- Subtype_Indication => New_Indic); -- Itypes must be analyzed with checks off + -- Declaration must have a parent for proper + -- handling of subsidiary actions. + Set_Parent (Subt_Decl, N); Analyze (Subt_Decl, Suppress => All_Checks); end; end if; *************** package body Exp_Aggr is *** 2073,2078 **** --- 2117,2123 ---- Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); Set_No_Initialization (N); + Initialize_Discriminants (N, Typ); end Convert_Aggr_In_Object_Decl; ---------------------------- *************** package body Exp_Aggr is *** 2151,2156 **** --- 2196,2202 ---- Set_No_Initialization (Instr); Insert_Action (N, Instr); + Initialize_Discriminants (Instr, Typ); Target_Expr := New_Occurrence_Of (Temp, Loc); Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr)); *************** package body Exp_Aggr is *** 2158,2163 **** --- 2204,2442 ---- Analyze_And_Resolve (N, Typ); end Convert_To_Assignments; + --------------------------- + -- Convert_To_Positional -- + --------------------------- + + procedure Convert_To_Positional + (N : Node_Id; + Max_Others_Replicate : Nat := 5; + Handle_Bit_Packed : Boolean := False) + is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ndim : constant Pos := Number_Dimensions (Typ); + Xtyp : constant Entity_Id := Etype (First_Index (Typ)); + Indx : constant Node_Id := First_Index (Base_Type (Typ)); + Blo : constant Node_Id := Type_Low_Bound (Etype (Indx)); + Lo : constant Node_Id := Type_Low_Bound (Xtyp); + Hi : constant Node_Id := Type_High_Bound (Xtyp); + Lov : Uint; + Hiv : Uint; + + -- The following constant determines the maximum size of an + -- aggregate produced by converting named to positional + -- notation (e.g. from others clauses). This avoids running + -- away with attempts to convert huge aggregates. + + -- The normal limit is 5000, but we increase this limit to + -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) + -- or Restrictions (No_Implicit_Loops) is specified, since in + -- either case, we are at risk of declaring the program illegal + -- because of this limit. + + Max_Aggr_Size : constant Nat := + 5000 + (2 ** 24 - 5000) * Boolean'Pos + (Restrictions (No_Elaboration_Code) + or else + Restrictions (No_Implicit_Loops)); + + begin + -- For now, we only handle the one dimensional case and aggregates + -- that are not part of a component_association + + if Ndim > 1 or else Nkind (Parent (N)) = N_Aggregate + or else Nkind (Parent (N)) = N_Component_Association + then + return; + end if; + + -- If already positional, nothing to do! + + if No (Component_Associations (N)) then + return; + end if; + + -- Bounds need to be known at compile time + + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return; + end if; + + -- Normally we do not attempt to convert bit packed arrays. The + -- exception is when we are explicitly asked to do so (this call + -- is from the Packed_Array_Aggregate_Handled procedure). + + if Is_Bit_Packed_Array (Typ) + and then not Handle_Bit_Packed + then + return; + end if; + + -- Do not convert to positional if controlled components are + -- involved since these require special processing + + if Has_Controlled_Component (Typ) then + return; + end if; + + -- Get bounds and check reasonable size (positive, not too large) + -- Also only handle bounds starting at the base type low bound for now + -- since the compiler isn't able to handle different low bounds yet. + + Lov := Expr_Value (Lo); + Hiv := Expr_Value (Hi); + + if Hiv < Lov + or else (Hiv - Lov > Max_Aggr_Size) + or else not Compile_Time_Known_Value (Blo) + or else (Lov /= Expr_Value (Blo)) + then + return; + end if; + + -- Bounds must be in integer range (for array Vals below) + + if not UI_Is_In_Int_Range (Lov) + or else + not UI_Is_In_Int_Range (Hiv) + then + return; + end if; + + -- Determine if set of alternatives is suitable for conversion + -- and build an array containing the values in sequence. + + declare + Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) + of Node_Id := (others => Empty); + -- The values in the aggregate sorted appropriately + + Vlist : List_Id; + -- Same data as Vals in list form + + Rep_Count : Nat; + -- Used to validate Max_Others_Replicate limit + + Elmt : Node_Id; + Num : Int := UI_To_Int (Lov); + Choice : Node_Id; + Lo, Hi : Node_Id; + + begin + if Present (Expressions (N)) then + Elmt := First (Expressions (N)); + while Present (Elmt) loop + Vals (Num) := Relocate_Node (Elmt); + Num := Num + 1; + Next (Elmt); + end loop; + end if; + + Elmt := First (Component_Associations (N)); + Component_Loop : while Present (Elmt) loop + + Choice := First (Choices (Elmt)); + Choice_Loop : while Present (Choice) loop + + -- If we have an others choice, fill in the missing elements + -- subject to the limit established by Max_Others_Replicate. + + if Nkind (Choice) = N_Others_Choice then + Rep_Count := 0; + + for J in Vals'Range loop + if No (Vals (J)) then + Vals (J) := New_Copy_Tree (Expression (Elmt)); + Rep_Count := Rep_Count + 1; + + -- Check for maximum others replication. Note that + -- we skip this test if either of the restrictions + -- No_Elaboration_Code or No_Implicit_Loops is + -- active, or if this is a preelaborable unit. + + if Rep_Count > Max_Others_Replicate + and then not Restrictions (No_Elaboration_Code) + and then not Restrictions (No_Implicit_Loops) + and then not + Is_Preelaborated (Cunit_Entity (Current_Sem_Unit)) + then + return; + end if; + end if; + end loop; + + exit Component_Loop; + + -- Case of a subtype mark + + elsif (Nkind (Choice) = N_Identifier + and then Is_Type (Entity (Choice))) + then + Lo := Type_Low_Bound (Etype (Choice)); + Hi := Type_High_Bound (Etype (Choice)); + + -- Case of subtype indication + + elsif Nkind (Choice) = N_Subtype_Indication then + Lo := Low_Bound (Range_Expression (Constraint (Choice))); + Hi := High_Bound (Range_Expression (Constraint (Choice))); + + -- Case of a range + + elsif Nkind (Choice) = N_Range then + Lo := Low_Bound (Choice); + Hi := High_Bound (Choice); + + -- Normal subexpression case + + else pragma Assert (Nkind (Choice) in N_Subexpr); + if not Compile_Time_Known_Value (Choice) then + return; + + else + Vals (UI_To_Int (Expr_Value (Choice))) := + New_Copy_Tree (Expression (Elmt)); + goto Continue; + end if; + end if; + + -- Range cases merge with Lo,Hi said + + if not Compile_Time_Known_Value (Lo) + or else + not Compile_Time_Known_Value (Hi) + then + return; + else + for J in UI_To_Int (Expr_Value (Lo)) .. + UI_To_Int (Expr_Value (Hi)) + loop + Vals (J) := New_Copy_Tree (Expression (Elmt)); + end loop; + end if; + + <> + Next (Choice); + end loop Choice_Loop; + + Next (Elmt); + end loop Component_Loop; + + -- If we get here the conversion is possible + + Vlist := New_List; + for J in Vals'Range loop + Append (Vals (J), Vlist); + end loop; + + Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); + Analyze_And_Resolve (N, Typ); + end; + end Convert_To_Positional; + ---------------------------- -- Expand_Array_Aggregate -- ---------------------------- *************** package body Exp_Aggr is *** 2190,2196 **** Typ : constant Entity_Id := Etype (N); Ctyp : constant Entity_Id := Component_Type (Typ); ! -- Typ is the correct constrained array subtype of the aggregate and -- Ctyp is the corresponding component type. Aggr_Dimension : constant Pos := Number_Dimensions (Typ); --- 2469,2475 ---- Typ : constant Entity_Id := Etype (N); Ctyp : constant Entity_Id := Component_Type (Typ); ! -- Typ is the correct constrained array subtype of the aggregate -- Ctyp is the corresponding component type. Aggr_Dimension : constant Pos := Number_Dimensions (Typ); *************** package body Exp_Aggr is *** 2208,2217 **** -- is the expression in an assignment, assignment in place may be -- possible, provided other conditions are met on the LHS. ! Others_Present : array (1 .. Aggr_Dimension) of Boolean ! := (others => False); ! -- If Others_Present (I) is True, then there is an others choice ! -- in one of the sub-aggregates of N at dimension I. procedure Build_Constrained_Type (Positional : Boolean); -- If the subtype is not static or unconstrained, build a constrained --- 2487,2496 ---- -- is the expression in an assignment, assignment in place may be -- possible, provided other conditions are met on the LHS. ! Others_Present : array (1 .. Aggr_Dimension) of Boolean := ! (others => False); ! -- If Others_Present (J) is True, then there is an others choice ! -- in one of the sub-aggregates of N at dimension J. procedure Build_Constrained_Type (Positional : Boolean); -- If the subtype is not static or unconstrained, build a constrained *************** package body Exp_Aggr is *** 2233,2244 **** -- array sub-aggregate we start the computation from. Dim is the -- dimension corresponding to the sub-aggregate. - procedure Convert_To_Positional (N : Node_Id); - -- If possible, convert named notation to positional notation. This - -- conversion is possible only in some static cases. If the conversion - -- is possible, then N is rewritten with the analyzed converted - -- aggregate. - function Has_Address_Clause (D : Node_Id) return Boolean; -- If the aggregate is the expression in an object declaration, it -- cannot be expanded in place. This function does a lookahead in the --- 2512,2517 ---- *************** package body Exp_Aggr is *** 2401,2407 **** Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False); Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False); Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, Condition => Cond)); end if; end Check_Bounds; --- 2674,2682 ---- Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False); Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False); Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Length_Check_Failed)); end if; end Check_Bounds; *************** package body Exp_Aggr is *** 2473,2479 **** if Present (Cond) then Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, Condition => Cond)); end if; -- Now look inside the sub-aggregate to see if there is more work --- 2748,2756 ---- if Present (Cond) then Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Length_Check_Failed)); end if; -- Now look inside the sub-aggregate to see if there is more work *************** package body Exp_Aggr is *** 2514,2519 **** --- 2791,2797 ---- begin if Present (Component_Associations (Sub_Aggr)) then Assoc := Last (Component_Associations (Sub_Aggr)); + if Nkind (First (Choices (Assoc))) = N_Others_Choice then Others_Present (Dim) := True; end if; *************** package body Exp_Aggr is *** 2546,2769 **** end if; end Compute_Others_Present; - --------------------------- - -- Convert_To_Positional -- - --------------------------- - - procedure Convert_To_Positional (N : Node_Id) is - Typ : constant Entity_Id := Etype (N); - Ndim : constant Pos := Number_Dimensions (Typ); - Xtyp : constant Entity_Id := Etype (First_Index (Typ)); - Blo : constant Node_Id := - Type_Low_Bound (Etype (First_Index (Base_Type (Typ)))); - Lo : constant Node_Id := Type_Low_Bound (Xtyp); - Hi : constant Node_Id := Type_High_Bound (Xtyp); - Lov : Uint; - Hiv : Uint; - - Max_Aggr_Size : constant := 500; - -- Maximum size of aggregate produced by converting positional to - -- named notation. This avoids running away with attempts to - -- convert huge aggregates. - - Max_Others_Replicate : constant := 5; - -- This constant defines the maximum expansion of an others clause - -- into a list of values. This applies when converting a named - -- aggregate to positional form for processing by the back end. - -- If a given others clause generates more than five values, the - -- aggregate is retained as named, since the loop is more compact. - -- However, this constant is completely overridden if restriction - -- No_Elaboration_Code is active, since in this case, the loop - -- would not be allowed anyway. Similarly No_Implicit_Loops causes - -- this parameter to be ignored. - - begin - -- For now, we only handle the one dimensional case and aggregates - -- that are not part of a component_association - - if Ndim > 1 or else Nkind (Parent (N)) = N_Aggregate - or else Nkind (Parent (N)) = N_Component_Association - then - return; - end if; - - -- If already positional, nothing to do! - - if No (Component_Associations (N)) then - return; - end if; - - -- Bounds need to be known at compile time - - if not Compile_Time_Known_Value (Lo) - or else not Compile_Time_Known_Value (Hi) - then - return; - end if; - - -- Do not attempt to convert bit packed arrays, since they cannot - -- be handled by the backend in any case. - - if Is_Bit_Packed_Array (Typ) then - return; - end if; - - -- Do not convert to positional if controlled components are - -- involved since these require special processing - - if Has_Controlled_Component (Typ) then - return; - end if; - - -- Get bounds and check reasonable size (positive, not too large) - -- Also only handle bounds starting at the base type low bound for - -- now since the compiler isn't able to handle different low bounds - -- yet - - Lov := Expr_Value (Lo); - Hiv := Expr_Value (Hi); - - if Hiv < Lov - or else (Hiv - Lov > Max_Aggr_Size) - or else not Compile_Time_Known_Value (Blo) - or else (Lov /= Expr_Value (Blo)) - then - return; - end if; - - -- Bounds must be in integer range (for array Vals below) - - if not UI_Is_In_Int_Range (Lov) - or else - not UI_Is_In_Int_Range (Hiv) - then - return; - end if; - - -- Determine if set of alternatives is suitable for conversion - -- and build an array containing the values in sequence. - - declare - Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) - of Node_Id := (others => Empty); - -- The values in the aggregate sorted appropriately - - Vlist : List_Id; - -- Same data as Vals in list form - - Rep_Count : Nat; - -- Used to validate Max_Others_Replicate limit - - Elmt : Node_Id; - Num : Int := UI_To_Int (Lov); - Choice : Node_Id; - Lo, Hi : Node_Id; - - begin - if Present (Expressions (N)) then - Elmt := First (Expressions (N)); - while Present (Elmt) loop - Vals (Num) := Relocate_Node (Elmt); - Num := Num + 1; - Next (Elmt); - end loop; - end if; - - Elmt := First (Component_Associations (N)); - Component_Loop : while Present (Elmt) loop - - Choice := First (Choices (Elmt)); - Choice_Loop : while Present (Choice) loop - - -- If we have an others choice, fill in the missing elements - -- subject to the limit established by Max_Others_Replicate. - - if Nkind (Choice) = N_Others_Choice then - Rep_Count := 0; - - for J in Vals'Range loop - if No (Vals (J)) then - Vals (J) := New_Copy_Tree (Expression (Elmt)); - Rep_Count := Rep_Count + 1; - - if Rep_Count > Max_Others_Replicate - and then not Restrictions (No_Elaboration_Code) - and then not Restrictions (No_Implicit_Loops) - then - return; - end if; - end if; - end loop; - - exit Component_Loop; - - -- Case of a subtype mark - - elsif (Nkind (Choice) = N_Identifier - and then Is_Type (Entity (Choice))) - then - Lo := Type_Low_Bound (Etype (Choice)); - Hi := Type_High_Bound (Etype (Choice)); - - -- Case of subtype indication - - elsif Nkind (Choice) = N_Subtype_Indication then - Lo := Low_Bound (Range_Expression (Constraint (Choice))); - Hi := High_Bound (Range_Expression (Constraint (Choice))); - - -- Case of a range - - elsif Nkind (Choice) = N_Range then - Lo := Low_Bound (Choice); - Hi := High_Bound (Choice); - - -- Normal subexpression case - - else pragma Assert (Nkind (Choice) in N_Subexpr); - if not Compile_Time_Known_Value (Choice) then - return; - - else - Vals (UI_To_Int (Expr_Value (Choice))) := - New_Copy_Tree (Expression (Elmt)); - goto Continue; - end if; - end if; - - -- Range cases merge with Lo,Hi said - - if not Compile_Time_Known_Value (Lo) - or else - not Compile_Time_Known_Value (Hi) - then - return; - else - for J in UI_To_Int (Expr_Value (Lo)) .. - UI_To_Int (Expr_Value (Hi)) - loop - Vals (J) := New_Copy_Tree (Expression (Elmt)); - end loop; - end if; - - <> - Next (Choice); - end loop Choice_Loop; - - Next (Elmt); - end loop Component_Loop; - - -- If we get here the conversion is possible - - Vlist := New_List; - for J in Vals'Range loop - Append (Vals (J), Vlist); - end loop; - - Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); - Analyze_And_Resolve (N, Typ); - end; - end Convert_To_Positional; - ------------------------- -- Has_Address_Clause -- ------------------------- --- 2824,2829 ---- *************** package body Exp_Aggr is *** 2805,2810 **** --- 2865,2874 ---- Obj_Lo : Node_Id; Obj_Hi : Node_Id; + function Is_Others_Aggregate (Aggr : Node_Id) return Boolean; + -- Aggregates that consist of a single Others choice are safe + -- if the single expression is. + function Safe_Aggregate (Aggr : Node_Id) return Boolean; -- Check recursively that each component of a (sub)aggregate does -- not depend on the variable being assigned to. *************** package body Exp_Aggr is *** 2813,2818 **** --- 2877,2894 ---- -- Verify that an expression cannot depend on the variable being -- assigned to. Room for improvement here (but less than before). + ------------------------- + -- Is_Others_Aggregate -- + ------------------------- + + function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is + begin + return No (Expressions (Aggr)) + and then Nkind + (First (Choices (First (Component_Associations (Aggr))))) + = N_Others_Choice; + end Is_Others_Aggregate; + -------------------- -- Safe_Aggregate -- -------------------- *************** package body Exp_Aggr is *** 2907,2919 **** if not Analyzed (Comp) then if Is_Overloaded (Expr) then return False; end if; Comp := New_Copy_Tree (Expr); Analyze (Comp); end if; ! return Check_Component (Comp); end Safe_Component; -- Start of processing for In_Place_Assign_OK --- 2983,3010 ---- if not Analyzed (Comp) then if Is_Overloaded (Expr) then return False; + + elsif Nkind (Expr) = N_Aggregate + and then not Is_Others_Aggregate (Expr) + then + return False; + + elsif Nkind (Expr) = N_Allocator then + -- For now, too complex to analyze. + + return False; end if; Comp := New_Copy_Tree (Expr); + Set_Parent (Comp, Parent (Expr)); Analyze (Comp); end if; ! if Nkind (Comp) = N_Aggregate then ! return Safe_Aggregate (Comp); ! else ! return Check_Component (Comp); ! end if; end Safe_Component; -- Start of processing for In_Place_Assign_OK *************** package body Exp_Aggr is *** 2929,2939 **** -- are derived from the left-hand side, and the assignment is -- safe if the expression is. ! if No (Expressions (N)) ! and then Nkind ! (First (Choices (First (Component_Associations (N))))) ! = N_Others_Choice ! then return Safe_Component (Expression (First (Component_Associations (N)))); --- 3020,3026 ---- -- are derived from the left-hand side, and the assignment is -- safe if the expression is. ! if Is_Others_Aggregate (N) then return Safe_Component (Expression (First (Component_Associations (N)))); *************** package body Exp_Aggr is *** 3041,3047 **** end if; -- If we are dealing with a positional sub-aggregate with an ! -- others choice, compute the number or positional elements. if Need_To_Check and then Present (Expressions (Sub_Aggr)) then Expr := First (Expressions (Sub_Aggr)); --- 3128,3134 ---- end if; -- If we are dealing with a positional sub-aggregate with an ! -- others choice then compute the number or positional elements. if Need_To_Check and then Present (Expressions (Sub_Aggr)) then Expr := First (Expressions (Sub_Aggr)); *************** package body Exp_Aggr is *** 3056,3065 **** elsif Need_To_Check then Compute_Choices_Lo_And_Choices_Hi : declare Table : Case_Table_Type (1 .. Nb_Choices); -- Used to sort all the different choice values ! I : Pos := 1; Low : Node_Id; High : Node_Id; --- 3143,3153 ---- elsif Need_To_Check then Compute_Choices_Lo_And_Choices_Hi : declare + Table : Case_Table_Type (1 .. Nb_Choices); -- Used to sort all the different choice values ! J : Pos := 1; Low : Node_Id; High : Node_Id; *************** package body Exp_Aggr is *** 3073,3082 **** end if; Get_Index_Bounds (Choice, Low, High); ! Table (I).Choice_Lo := Low; ! Table (I).Choice_Hi := High; ! I := I + 1; Next (Choice); end loop; --- 3161,3170 ---- end if; Get_Index_Bounds (Choice, Low, High); ! Table (J).Choice_Lo := Low; ! Table (J).Choice_Hi := High; ! J := J + 1; Next (Choice); end loop; *************** package body Exp_Aggr is *** 3148,3154 **** if Present (Cond) then Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, Condition => Cond)); end if; -- Now look inside the sub-aggregate to see if there is more work --- 3236,3244 ---- if Present (Cond) then Insert_Action (N, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Length_Check_Failed)); end if; -- Now look inside the sub-aggregate to see if there is more work *************** package body Exp_Aggr is *** 3201,3210 **** return; end if; ! -- If during semantic analysis it has been determined that aggregate N ! -- will raise Constraint_Error at run-time, then the aggregate node ! -- has been replaced with an N_Raise_Constraint_Error node and we ! -- should never get here. pragma Assert (not Raises_Constraint_Error (N)); --- 3291,3300 ---- return; end if; ! -- If the semantic analyzer has determined that aggregate N will raise ! -- Constraint_Error at run-time, then the aggregate node has been ! -- replaced with an N_Raise_Constraint_Error node and we should ! -- never get here. pragma Assert (not Raises_Constraint_Error (N)); *************** package body Exp_Aggr is *** 3343,3348 **** --- 3433,3445 ---- -- Look if in place aggregate expansion is possible + -- First case to test for is packed array aggregate that we can + -- handle at compile time. If so, return with transformation done. + + if Packed_Array_Aggregate_Handled (N) then + return; + end if; + -- For object declarations we build the aggregate in place, unless -- the array is bit-packed or the component is controlled. *************** package body Exp_Aggr is *** 3370,3376 **** and then not Has_Controlled_Component (Typ) and then not Has_Address_Clause (Parent (N)) then - Tmp := Defining_Identifier (Parent (N)); Set_No_Initialization (Parent (N)); Set_Expression (Parent (N), Empty); --- 3467,3472 ---- *************** package body Exp_Aggr is *** 3402,3415 **** end if; elsif Maybe_In_Place_OK and then Nkind (Name (Parent (N))) = N_Slice ! and then Safe_Slice_Assignment (N, Typ) then ! -- Safe_Slice_Assignment rewrites assignment as a loop. return; else Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Tmp_Decl := Make_Object_Declaration --- 3498,3522 ---- end if; elsif Maybe_In_Place_OK + and then Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Tmp := Name (Parent (N)); + + if Etype (Tmp) /= Etype (N) then + Apply_Length_Check (N, Etype (Tmp)); + end if; + + elsif Maybe_In_Place_OK and then Nkind (Name (Parent (N))) = N_Slice ! and then Safe_Slice_Assignment (N) then ! -- Safe_Slice_Assignment rewrites assignment as a loop return; else + Maybe_In_Place_OK := False; Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Tmp_Decl := Make_Object_Declaration *************** package body Exp_Aggr is *** 3437,3447 **** -- index checks because this code is guaranteed not to raise CE -- on index checks. However we should *not* suppress all checks. ! Aggr_Code := ! Build_Array_Aggr_Code (N, ! Index => First_Index (Typ), ! Into => New_Reference_To (Tmp, Loc), ! Scalar_Comp => Is_Scalar_Type (Ctyp)); if Comes_From_Source (Tmp) then Insert_Actions_After (Parent (N), Aggr_Code); --- 3544,3568 ---- -- index checks because this code is guaranteed not to raise CE -- on index checks. However we should *not* suppress all checks. ! declare ! Target : Node_Id; ! ! begin ! if Nkind (Tmp) = N_Defining_Identifier then ! Target := New_Reference_To (Tmp, Loc); ! ! else ! -- Name in assignment is explicit dereference. ! ! Target := New_Copy (Tmp); ! end if; ! ! Aggr_Code := ! Build_Array_Aggr_Code (N, ! Index => First_Index (Typ), ! Into => Target, ! Scalar_Comp => Is_Scalar_Type (Ctyp)); ! end; if Comes_From_Source (Tmp) then Insert_Actions_After (Parent (N), Aggr_Code); *************** package body Exp_Aggr is *** 3450,3461 **** Insert_Actions (N, Aggr_Code); end if; if Nkind (Parent (N)) = N_Assignment_Statement ! and then Is_Entity_Name (Name (Parent (N))) ! and then Tmp = Entity (Name (Parent (N))) then Rewrite (Parent (N), Make_Null_Statement (Loc)); - Analyze (N); elsif Nkind (Parent (N)) /= N_Object_Declaration or else Tmp /= Defining_Identifier (Parent (N)) --- 3571,3583 ---- Insert_Actions (N, Aggr_Code); end if; + -- If the aggregate has been assigned in place, remove the original + -- assignment. + if Nkind (Parent (N)) = N_Assignment_Statement ! and then Maybe_In_Place_OK then Rewrite (Parent (N), Make_Null_Statement (Loc)); elsif Nkind (Parent (N)) /= N_Object_Declaration or else Tmp /= Defining_Identifier (Parent (N)) *************** package body Exp_Aggr is *** 3634,3655 **** -- can be handled by gigi. else ! if not Has_Discriminants (Typ) then ! ! -- This bizarre if/elsif is to avoid a compiler crash ??? null; elsif Is_Derived_Type (Typ) then ! -- Non-girder discriminants are replaced with girder discriminants ! declare First_Comp : Node_Id; Discriminant : Entity_Id; begin ! -- Remove all the discriminants First_Comp := First (Component_Associations (N)); --- 3756,3823 ---- -- can be handled by gigi. else ! -- If no discriminants, nothing special to do + if not Has_Discriminants (Typ) then null; + -- Case of discriminants present + elsif Is_Derived_Type (Typ) then ! -- For untagged types, non-girder discriminants are replaced ! -- with girder discriminants, which are the ones that gigi uses ! -- to describe the type and its components. ! Generate_Aggregate_For_Derived_Type : declare First_Comp : Node_Id; Discriminant : Entity_Id; + Constraints : List_Id := New_List; + Decl : Node_Id; + Num_Disc : Int := 0; + Num_Gird : Int := 0; + + procedure Prepend_Girder_Values (T : Entity_Id); + -- Scan the list of girder discriminants of the type, and + -- add their values to the aggregate being built. + + --------------------------- + -- Prepend_Girder_Values -- + --------------------------- + + procedure Prepend_Girder_Values (T : Entity_Id) is + begin + Discriminant := First_Girder_Discriminant (T); + + while Present (Discriminant) loop + New_Comp := + Make_Component_Association (Loc, + Choices => + New_List (New_Occurrence_Of (Discriminant, Loc)), + + Expression => + New_Copy_Tree ( + Get_Discriminant_Value ( + Discriminant, + Typ, + Discriminant_Constraint (Typ)))); + + if No (First_Comp) then + Prepend_To (Component_Associations (N), New_Comp); + else + Insert_After (First_Comp, New_Comp); + end if; + + First_Comp := New_Comp; + Next_Girder_Discriminant (Discriminant); + end loop; + end Prepend_Girder_Values; + + -- Start of processing for Generate_Aggregate_For_Derived_Type begin ! -- Remove the associations for the discriminant of ! -- the derived type. First_Comp := First (Component_Associations (N)); *************** package body Exp_Aggr is *** 3661,3697 **** E_Discriminant then Remove (Comp); end if; end loop; ! -- Insert girder discriminant associations ! -- in the correct order First_Comp := Empty; - Discriminant := First_Girder_Discriminant (Typ); - while Present (Discriminant) loop - New_Comp := - Make_Component_Association (Loc, - Choices => - New_List (New_Occurrence_Of (Discriminant, Loc)), ! Expression => ! New_Copy_Tree ( ! Get_Discriminant_Value ( ! Discriminant, ! Typ, ! Discriminant_Constraint (Typ)))); ! ! if No (First_Comp) then ! Prepend_To (Component_Associations (N), New_Comp); ! else ! Insert_After (First_Comp, New_Comp); ! end if; ! First_Comp := New_Comp; Next_Girder_Discriminant (Discriminant); end loop; ! end; end if; if Is_Tagged_Type (Typ) then --- 3829,3907 ---- E_Discriminant then Remove (Comp); + Num_Disc := Num_Disc + 1; end if; end loop; ! -- Insert girder discriminant associations in the correct ! -- order. If there are more girder discriminants than new ! -- discriminants, there is at least one new discriminant ! -- that constrains more than one of the girders. In this ! -- case we need to construct a proper subtype of the parent ! -- type, in order to supply values to all the components. ! -- Otherwise there is one-one correspondence between the ! -- constraints and the girder discriminants. First_Comp := Empty; ! Discriminant := First_Girder_Discriminant (Base_Type (Typ)); ! while Present (Discriminant) loop ! Num_Gird := Num_Gird + 1; Next_Girder_Discriminant (Discriminant); end loop; ! ! -- Case of more girder discriminants than new discriminants ! ! if Num_Gird > Num_Disc then ! ! -- Create a proper subtype of the parent type, which is ! -- the proper implementation type for the aggregate, and ! -- convert it to the intended target type. ! ! Discriminant := First_Girder_Discriminant (Base_Type (Typ)); ! ! while Present (Discriminant) loop ! New_Comp := ! New_Copy_Tree ( ! Get_Discriminant_Value ( ! Discriminant, ! Typ, ! Discriminant_Constraint (Typ))); ! Append (New_Comp, Constraints); ! Next_Girder_Discriminant (Discriminant); ! end loop; ! ! Decl := ! Make_Subtype_Declaration (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, ! New_Internal_Name ('T')), ! Subtype_Indication => ! Make_Subtype_Indication (Loc, ! Subtype_Mark => ! New_Occurrence_Of (Etype (Base_Type (Typ)), Loc), ! Constraint => ! Make_Index_Or_Discriminant_Constraint ! (Loc, Constraints))); ! ! Insert_Action (N, Decl); ! Prepend_Girder_Values (Base_Type (Typ)); ! ! Set_Etype (N, Defining_Identifier (Decl)); ! Set_Analyzed (N); ! ! Rewrite (N, Unchecked_Convert_To (Typ, N)); ! Analyze (N); ! ! -- Case where we do not have fewer new discriminants than ! -- girder discriminants, so in this case we can simply ! -- use the girder discriminants of the subtype. ! ! else ! Prepend_Girder_Values (Typ); ! end if; ! end Generate_Aggregate_For_Derived_Type; end if; if Is_Tagged_Type (Typ) then *************** package body Exp_Aggr is *** 3936,3961 **** return Nb_Choices; end Number_Of_Choices; --------------------------- -- Safe_Slice_Assignment -- --------------------------- ! function Safe_Slice_Assignment ! (N : Node_Id; ! Typ : Entity_Id) ! return Boolean ! is Loc : constant Source_Ptr := Sloc (Parent (N)); Pref : constant Node_Id := Prefix (Name (Parent (N))); Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N))); Expr : Node_Id; ! L_I : Entity_Id; L_Iter : Node_Id; L_Body : Node_Id; Stat : Node_Id; begin ! -- Generate: For J in Range loop Pref (I) := Expr; end loop; if Comes_From_Source (N) and then No (Expressions (N)) --- 4146,4409 ---- return Nb_Choices; end Number_Of_Choices; + ------------------------------------ + -- Packed_Array_Aggregate_Handled -- + ------------------------------------ + + -- The current version of this procedure will handle at compile time + -- any array aggregate that meets these conditions: + + -- One dimensional, bit packed + -- Underlying packed type is modular type + -- Bounds are within 32-bit Int range + -- All bounds and values are static + + function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ctyp : constant Entity_Id := Component_Type (Typ); + + Not_Handled : exception; + -- Exception raised if this aggregate cannot be handled + + begin + -- For now, handle only one dimensional bit packed arrays + + if not Is_Bit_Packed_Array (Typ) + or else Number_Dimensions (Typ) > 1 + or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ)) + then + return False; + end if; + + declare + Csiz : constant Nat := UI_To_Int (Component_Size (Typ)); + + Lo : Node_Id; + Hi : Node_Id; + -- Bounds of index type + + Lob : Uint; + Hib : Uint; + -- Values of bounds if compile time known + + function Get_Component_Val (N : Node_Id) return Uint; + -- Given a expression value N of the component type Ctyp, returns + -- A value of Csiz (component size) bits representing this value. + -- If the value is non-static or any other reason exists why the + -- value cannot be returned, then Not_Handled is raised. + + ----------------------- + -- Get_Component_Val -- + ----------------------- + + function Get_Component_Val (N : Node_Id) return Uint is + Val : Uint; + + begin + -- We have to analyze the expression here before doing any further + -- processing here. The analysis of such expressions is deferred + -- till expansion to prevent some problems of premature analysis. + + Analyze_And_Resolve (N, Ctyp); + + -- Must have a compile time value + + if not Compile_Time_Known_Value (N) then + raise Not_Handled; + end if; + + Val := Expr_Rep_Value (N); + + -- Adjust for bias, and strip proper number of bits + + if Has_Biased_Representation (Ctyp) then + Val := Val - Expr_Value (Type_Low_Bound (Ctyp)); + end if; + + return Val mod Uint_2 ** Csiz; + end Get_Component_Val; + + -- Here we know we have a one dimensional bit packed array + + begin + Get_Index_Bounds (First_Index (Typ), Lo, Hi); + + -- Cannot do anything if bounds are dynamic + + if not Compile_Time_Known_Value (Lo) + or else + not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + -- Or are silly out of range of int bounds + + Lob := Expr_Value (Lo); + Hib := Expr_Value (Hi); + + if not UI_Is_In_Int_Range (Lob) + or else + not UI_Is_In_Int_Range (Hib) + then + return False; + end if; + + -- At this stage we have a suitable aggregate for handling + -- at compile time (the only remaining checks, are that the + -- values of expressions in the aggregate are compile time + -- known (check performed by Get_Component_Val), and that + -- any subtypes or ranges are statically known. + + -- If the aggregate is not fully positional at this stage, + -- then convert it to positional form. Either this will fail, + -- in which case we can do nothing, or it will succeed, in + -- which case we have succeeded in handling the aggregate, + -- or it will stay an aggregate, in which case we have failed + -- to handle this case. + + if Present (Component_Associations (N)) then + Convert_To_Positional + (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); + return Nkind (N) /= N_Aggregate; + end if; + + -- Otherwise we are all positional, so convert to proper value + + declare + Lov : constant Nat := UI_To_Int (Lob); + Hiv : constant Nat := UI_To_Int (Hib); + + Len : constant Nat := Int'Max (0, Hiv - Lov + 1); + -- The length of the array (number of elements) + + Aggregate_Val : Uint; + -- Value of aggregate. The value is set in the low order + -- bits of this value. For the little-endian case, the + -- values are stored from low-order to high-order and + -- for the big-endian case the values are stored from + -- high-order to low-order. Note that gigi will take care + -- of the conversions to left justify the value in the big + -- endian case (because of left justified modular type + -- processing), so we do not have to worry about that here. + + Lit : Node_Id; + -- Integer literal for resulting constructed value + + Shift : Nat; + -- Shift count from low order for next value + + Incr : Int; + -- Shift increment for loop + + Expr : Node_Id; + -- Next expression from positional parameters of aggregate + + begin + -- For little endian, we fill up the low order bits of the + -- target value. For big endian we fill up the high order + -- bits of the target value (which is a left justified + -- modular value). + + if Bytes_Big_Endian xor Debug_Flag_8 then + Shift := Csiz * (Len - 1); + Incr := -Csiz; + else + Shift := 0; + Incr := +Csiz; + end if; + + -- Loop to set the values + + Aggregate_Val := Uint_0; + Expr := First (Expressions (N)); + for J in 1 .. Len loop + Aggregate_Val := + Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift; + Shift := Shift + Incr; + Next (Expr); + end loop; + + -- Now we can rewrite with the proper value + + Lit := + Make_Integer_Literal (Loc, + Intval => Aggregate_Val); + Set_Print_In_Hex (Lit); + + -- Construct the expression using this literal. Note that it is + -- important to qualify the literal with its proper modular type + -- since universal integer does not have the required range and + -- also this is a left justified modular type, which is important + -- in the big-endian case. + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Packed_Array_Type (Typ), Loc), + Expression => Lit))); + + Analyze_And_Resolve (N, Typ); + return True; + end; + end; + + exception + when Not_Handled => + return False; + end Packed_Array_Aggregate_Handled; + + ------------------------------ + -- Initialize_Discriminants -- + ------------------------------ + + procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Bas : constant Entity_Id := Base_Type (Typ); + Par : constant Entity_Id := Etype (Bas); + Decl : constant Node_Id := Parent (Par); + Ref : Node_Id; + + begin + if Is_Tagged_Type (Bas) + and then Is_Derived_Type (Bas) + and then Has_Discriminants (Par) + and then Has_Discriminants (Bas) + and then Number_Discriminants (Bas) /= Number_Discriminants (Par) + and then Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + and then Present + (Variant_Part (Component_List (Type_Definition (Decl)))) + and then Nkind (N) /= N_Extension_Aggregate + then + + -- Call init_proc to set discriminants. + -- There should eventually be a special procedure for this ??? + + Ref := New_Reference_To (Defining_Identifier (N), Loc); + Insert_Actions_After (N, + Build_Initialization_Call (Sloc (N), Ref, Typ)); + end if; + end Initialize_Discriminants; + --------------------------- -- Safe_Slice_Assignment -- --------------------------- ! function Safe_Slice_Assignment (N : Node_Id) return Boolean is Loc : constant Source_Ptr := Sloc (Parent (N)); Pref : constant Node_Id := Prefix (Name (Parent (N))); Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N))); Expr : Node_Id; ! L_J : Entity_Id; L_Iter : Node_Id; L_Body : Node_Id; Stat : Node_Id; begin ! -- Generate: for J in Range loop Pref (J) := Expr; end loop; if Comes_From_Source (N) and then No (Expressions (N)) *************** package body Exp_Aggr is *** 3964,3977 **** then Expr := Expression (First (Component_Associations (N))); ! L_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); L_Iter := Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, ! Defining_Identifier => L_I, Discrete_Subtype_Definition => Relocate_Node (Range_Node))); L_Body := --- 4412,4425 ---- then Expr := Expression (First (Component_Associations (N))); ! L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); L_Iter := Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, ! Defining_Identifier => L_J, Discrete_Subtype_Definition => Relocate_Node (Range_Node))); L_Body := *************** package body Exp_Aggr is *** 3979,3985 **** Name => Make_Indexed_Component (Loc, Prefix => Relocate_Node (Pref), ! Expressions => New_List (New_Occurrence_Of (L_I, Loc))), Expression => Relocate_Node (Expr)); -- Construct the final loop --- 4427,4433 ---- Name => Make_Indexed_Component (Loc, Prefix => Relocate_Node (Pref), ! Expressions => New_List (New_Occurrence_Of (L_J, Loc))), Expression => Relocate_Node (Expr)); -- Construct the final loop diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_aggr.ads gcc-3.3/gcc/ada/exp_aggr.ads *** gcc-3.2.3/gcc/ada/exp_aggr.ads 2002-05-04 03:27:43.000000000 +0000 --- gcc-3.3/gcc/ada/exp_aggr.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/expander.adb gcc-3.3/gcc/ada/expander.adb *** gcc-3.2.3/gcc/ada/expander.adb 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/expander.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Expander is *** 103,109 **** -- expansion on (see the spec of sem). -- Finally, expansion is turned off in a regular compilation if there ! -- are semantic errors. In that case there will be no further expansion, -- but one cleanup action may be required: if a transient scope was -- created (e.g. for a function that returns an unconstrained type) -- the scope may still be on the stack, and must be removed explicitly, --- 102,108 ---- -- expansion on (see the spec of sem). -- Finally, expansion is turned off in a regular compilation if there ! -- are serious errors. In that case there will be no further expansion, -- but one cleanup action may be required: if a transient scope was -- created (e.g. for a function that returns an unconstrained type) -- the scope may still be on the stack, and must be removed explicitly, *************** package body Expander is *** 113,119 **** if not Expander_Active then Set_Analyzed (N, Full_Analysis); ! if Errors_Detected > 0 and then Scope_Is_Transient then Scope_Stack.Table --- 112,118 ---- if not Expander_Active then Set_Analyzed (N, Full_Analysis); ! if Serious_Errors_Detected > 0 and then Scope_Is_Transient then Scope_Stack.Table *************** package body Expander is *** 127,133 **** return; else - Debug_A_Entry ("expanding ", N); -- Processing depends on node kind. For full details on the expansion --- 126,131 ---- *************** package body Expander is *** 473,479 **** Expander_Active := Expander_Flags.Table (Expander_Flags.Last); Expander_Flags.Decrement_Last; ! if Errors_Detected /= 0 then Expander_Active := False; end if; end Expander_Mode_Restore; --- 471,477 ---- Expander_Active := Expander_Flags.Table (Expander_Flags.Last); Expander_Flags.Decrement_Last; ! if Serious_Errors_Detected /= 0 then Expander_Active := False; end if; end Expander_Mode_Restore; diff -Nrc3pad gcc-3.2.3/gcc/ada/expander.ads gcc-3.3/gcc/ada/expander.ads *** gcc-3.2.3/gcc/ada/expander.ads 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/expander.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_attr.adb gcc-3.3/gcc/ada/exp_attr.adb *** gcc-3.2.3/gcc/ada/exp_attr.adb 2002-05-04 03:27:43.000000000 +0000 --- gcc-3.3/gcc/ada/exp_attr.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Rtsfind; use Rtsfind; *** 48,54 **** with Sem; use Sem; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; - with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; --- 47,52 ---- *************** package body Exp_Attr is *** 452,458 **** declare Agg : Node_Id; Sub : Entity_Id; ! E_T : constant Entity_Id := Equivalent_Type (Typ); Acc : constant Entity_Id := Etype (Next_Component (First_Component (E_T))); Obj_Ref : Node_Id; --- 450,456 ---- declare Agg : Node_Id; Sub : Entity_Id; ! E_T : constant Entity_Id := Equivalent_Type (Btyp); Acc : constant Entity_Id := Etype (Next_Component (First_Component (E_T))); Obj_Ref : Node_Id; *************** package body Exp_Attr is *** 511,517 **** Rewrite (N, Agg); ! Analyze_And_Resolve (N, Equivalent_Type (Typ)); -- For subsequent analysis, the node must retain its type. -- The backend will replace it with the equivalent type where --- 509,515 ---- Rewrite (N, Agg); ! Analyze_And_Resolve (N, E_T); -- For subsequent analysis, the node must retain its type. -- The backend will replace it with the equivalent type where *************** package body Exp_Attr is *** 3761,3768 **** Attribute_Machine_Overflows | Attribute_Machine_Radix | Attribute_Machine_Rounds | - Attribute_Max_Interrupt_Priority | - Attribute_Max_Priority | Attribute_Maximum_Alignment | Attribute_Model_Emin | Attribute_Model_Epsilon | --- 3759,3764 ---- *************** package body Exp_Attr is *** 3780,3786 **** Attribute_Signed_Zeros | Attribute_Small | Attribute_Storage_Unit | - Attribute_Tick | Attribute_Type_Class | Attribute_Universal_Literal_String | Attribute_Wchar_T_Size | --- 3776,3781 ---- *************** package body Exp_Attr is *** 3836,3842 **** Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Base_Type (Etype (Prefix (N))), Loc), ! Attribute_Name => Cnam)))); end Expand_Pred_Succ; --- 3831,3838 ---- Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Base_Type (Etype (Prefix (N))), Loc), ! Attribute_Name => Cnam)), ! Reason => CE_Overflow_Check_Failed)); end Expand_Pred_Succ; *************** package body Exp_Attr is *** 3862,3879 **** -- If Typ is a derived type, it may inherit attributes from some -- ancestor which is not the ultimate underlying one. if Is_Derived_Type (P_Type) then ! while Is_Derived_Type (P_Type) loop ! Proc := TSS (Base_Type (Etype (Typ)), Nam); ! ! if Present (Proc) then ! return Proc; ! else ! P_Type := Base_Type (Etype (P_Type)); ! end if; ! end loop; end if; -- If nothing else, use the TSS of the root type. --- 3858,3880 ---- -- If Typ is a derived type, it may inherit attributes from some -- ancestor which is not the ultimate underlying one. + -- If Typ is a derived tagged type, the corresponding primitive + -- operation has been created explicitly. if Is_Derived_Type (P_Type) then + if Is_Tagged_Type (P_Type) then + return Find_Prim_Op (P_Type, Nam); + else + while Is_Derived_Type (P_Type) loop + Proc := TSS (Base_Type (Etype (Typ)), Nam); ! if Present (Proc) then ! return Proc; ! else ! P_Type := Base_Type (Etype (P_Type)); ! end if; ! end loop; ! end if; end if; -- If nothing else, use the TSS of the root type. diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_attr.ads gcc-3.3/gcc/ada/exp_attr.ads *** gcc-3.2.3/gcc/ada/exp_attr.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/exp_attr.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch10.ads gcc-3.3/gcc/ada/exp_ch10.ads *** gcc-3.2.3/gcc/ada/exp_ch10.ads 2002-05-07 08:22:11.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch10.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch11.adb gcc-3.3/gcc/ada/exp_ch11.adb *** gcc-3.2.3/gcc/ada/exp_ch11.adb 2002-05-04 03:27:45.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch11.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Atree; use Atree; *** 30,35 **** --- 29,35 ---- with Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; + with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; with Exp_Util; use Exp_Util; with Hostparm; use Hostparm; *************** package body Exp_Ch11 is *** 657,674 **** -- Routine to prepend a call to the procedure referenced by Proc at -- the start of the handler code for the current Handler. procedure Prepend_Call_To_Handler (Proc : RE_Id; Args : List_Id := No_List) is ! Call : constant Node_Id := ! Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (Proc), Loc), ! Parameter_Associations => Args); begin ! Prepend_To (Statements (Handler), Call); ! Analyze (Call, Suppress => All_Checks); end Prepend_Call_To_Handler; -- Start of processing for Expand_Exception_Handlers --- 657,688 ---- -- Routine to prepend a call to the procedure referenced by Proc at -- the start of the handler code for the current Handler. + ----------------------------- + -- Prepend_Call_To_Handler -- + ----------------------------- + procedure Prepend_Call_To_Handler (Proc : RE_Id; Args : List_Id := No_List) is ! Ent : constant Entity_Id := RTE (Proc); begin ! -- If we have no Entity, then we are probably in no run time mode ! -- or some weird error has occured. In either case do do nothing! ! ! if Present (Ent) then ! declare ! Call : constant Node_Id := ! Make_Procedure_Call_Statement (Loc, ! Name => New_Occurrence_Of (RTE (Proc), Loc), ! Parameter_Associations => Args); ! ! begin ! Prepend_To (Statements (Handler), Call); ! Analyze (Call, Suppress => All_Checks); ! end; ! end if; end Prepend_Call_To_Handler; -- Start of processing for Expand_Exception_Handlers *************** package body Exp_Ch11 is *** 934,940 **** procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is begin ! if Present (Exception_Handlers (N)) then Expand_Exception_Handlers (N); end if; --- 948,956 ---- procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is begin ! if Present (Exception_Handlers (N)) ! and then not Restrictions (No_Exception_Handlers) ! then Expand_Exception_Handlers (N); end if; *************** package body Exp_Ch11 is *** 1007,1024 **** -- but this is also faster in all modes). if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then ! if Entity (Name (N)) = Standard_Program_Error then ! Rewrite (N, Make_Raise_Program_Error (Loc)); Analyze (N); return; ! elsif Entity (Name (N)) = Standard_Constraint_Error then ! Rewrite (N, Make_Raise_Constraint_Error (Loc)); Analyze (N); return; elsif Entity (Name (N)) = Standard_Storage_Error then ! Rewrite (N, Make_Raise_Storage_Error (Loc)); Analyze (N); return; end if; --- 1023,1046 ---- -- but this is also faster in all modes). if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then ! if Entity (Name (N)) = Standard_Constraint_Error then ! Rewrite (N, ! Make_Raise_Constraint_Error (Loc, ! Reason => CE_Explicit_Raise)); Analyze (N); return; ! elsif Entity (Name (N)) = Standard_Program_Error then ! Rewrite (N, ! Make_Raise_Program_Error (Loc, ! Reason => PE_Explicit_Raise)); Analyze (N); return; elsif Entity (Name (N)) = Standard_Storage_Error then ! Rewrite (N, ! Make_Raise_Storage_Error (Loc, ! Reason => SE_Explicit_Raise)); Analyze (N); return; end if; *************** package body Exp_Ch11 is *** 1037,1042 **** --- 1059,1071 ---- begin Build_Location_String (Loc); + -- If the exception is a renaming, use the exception that it + -- renames (which might be a predefined exception, e.g.). + + if Present (Renamed_Object (Id)) then + Id := Renamed_Object (Id); + end if; + -- Build a C compatible string in case of no exception handlers, -- since this is what the last chance handler is expecting. *************** package body Exp_Ch11 is *** 1234,1239 **** --- 1263,1272 ---- return; end if; + if Restrictions (No_Exception_Handlers) then + return; + end if; + -- Suppress descriptor if we are not generating code. This happens -- in the case of a -gnatc -gnatt compilation where we force generics -- to be generated, but we still don't want exception tables. *************** package body Exp_Ch11 is *** 1583,1588 **** --- 1616,1635 ---- Adecl : Node_Id; begin + -- If N is empty with prior errors, ignore + + if Total_Errors_Detected /= 0 and then No (N) then + return; + end if; + + -- Do not generate if no exceptions + + if Restrictions (No_Exception_Handlers) then + return; + end if; + + -- Otherwise generate descriptor + Adecl := Aux_Decls_Node (Parent (N)); if No (Actions (Adecl)) then *************** package body Exp_Ch11 is *** 1600,1615 **** (N : Node_Id; Spec : Entity_Id) is - HSS : constant Node_Id := Handled_Statement_Sequence (N); - begin ! if No (Exception_Handlers (HSS)) then ! Generate_Subprogram_Descriptor ! (N, Sloc (N), Spec, Statements (HSS)); ! else ! Generate_Subprogram_Descriptor ! (N, Sloc (N), Spec, Statements (Last (Exception_Handlers (HSS)))); end if; end Generate_Subprogram_Descriptor_For_Subprogram; ----------------------------------- --- 1647,1680 ---- (N : Node_Id; Spec : Entity_Id) is begin ! -- If we have no subprogram body and prior errors, ignore ! ! if Total_Errors_Detected /= 0 and then No (N) then ! return; end if; + + -- Do not generate if no exceptions + + if Restrictions (No_Exception_Handlers) then + return; + end if; + + -- Else generate descriptor + + declare + HSS : constant Node_Id := Handled_Statement_Sequence (N); + + begin + if No (Exception_Handlers (HSS)) then + Generate_Subprogram_Descriptor + (N, Sloc (N), Spec, Statements (HSS)); + else + Generate_Subprogram_Descriptor + (N, Sloc (N), + Spec, Statements (Last (Exception_Handlers (HSS)))); + end if; + end; end Generate_Subprogram_Descriptor_For_Subprogram; ----------------------------------- *************** package body Exp_Ch11 is *** 1635,1640 **** --- 1700,1711 ---- return; end if; + -- Nothing to do if no exceptions + + if Restrictions (No_Exception_Handlers) then + return; + end if; + -- Remove any entries from SD_List that correspond to eliminated -- subprograms. diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch11.ads gcc-3.3/gcc/ada/exp_ch11.ads *** gcc-3.2.3/gcc/ada/exp_ch11.ads 2002-05-04 03:27:45.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch11.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch12.adb gcc-3.3/gcc/ada/exp_ch12.adb *** gcc-3.2.3/gcc/ada/exp_ch12.adb 2002-05-04 03:27:46.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch12.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,13 ---- -- -- -- 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 Exp_Ch12 is *** 62,68 **** Condition => Make_Op_Not (Loc, Right_Opnd => ! New_Occurrence_Of (Elaboration_Entity (Ent), Loc)))); end if; end Expand_N_Generic_Instantiation; --- 61,68 ---- Condition => Make_Op_Not (Loc, Right_Opnd => ! New_Occurrence_Of (Elaboration_Entity (Ent), Loc)), ! Reason => PE_Access_Before_Elaboration)); end if; end Expand_N_Generic_Instantiation; diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch12.ads gcc-3.3/gcc/ada/exp_ch12.ads *** gcc-3.2.3/gcc/ada/exp_ch12.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch12.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch13.adb gcc-3.3/gcc/ada/exp_ch13.adb *** gcc-3.2.3/gcc/ada/exp_ch13.adb 2002-05-04 03:27:46.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch13.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Uintp; use Uintp; *** 50,55 **** --- 49,59 ---- package body Exp_Ch13 is + procedure Expand_External_Tag_Definition (N : Node_Id); + -- The code to assign and register an external tag must be elaborated + -- after the dispatch table has been created, so the expansion of the + -- attribute definition node is delayed until after the type is frozen. + ------------------------------------------ -- Expand_N_Attribute_Definition_Clause -- ------------------------------------------ *************** package body Exp_Ch13 is *** 115,184 **** end if; ------------------ - -- External_Tag -- - ------------------ - - -- For the rep clause "for x'external_tag use y" generate: - - -- xV : constant string := y; - -- Set_External_Tag (x'tag, xV'Address); - -- Register_Tag (x'tag); - - -- note that register_tag has been delayed up to now because - -- the external_tag must be set before resistering. - - when Attribute_External_Tag => External_Tag : declare - E : Entity_Id; - Old_Val : String_Id := Strval (Expr_Value_S (Exp)); - New_Val : String_Id; - - begin - -- Create a new nul terminated string if it is not already - - if String_Length (Old_Val) > 0 - and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 - then - New_Val := Old_Val; - else - Start_String (Old_Val); - Store_String_Char (Get_Char_Code (ASCII.NUL)); - New_Val := End_String; - end if; - - E := - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Ent), 'A')); - - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => E, - Constant_Present => True, - Object_Definition => - New_Reference_To (Standard_String, Loc), - Expression => - Make_String_Literal (Loc, Strval => New_Val))); - - Insert_Actions (N, New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Tag, - Prefix => New_Occurrence_Of (Ent, Loc)), - - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Address, - Prefix => New_Occurrence_Of (E, Loc)))), - - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Register_Tag), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Tag, - Prefix => New_Occurrence_Of (Ent, Loc)))))); - end External_Tag; - - ------------------ -- Storage_Size -- ------------------ --- 119,124 ---- *************** package body Exp_Ch13 is *** 224,229 **** --- 164,239 ---- end Expand_N_Attribute_Definition_Clause; + ------------------------------------- + -- Expand_External_Tag_Definition -- + ------------------------------------- + + procedure Expand_External_Tag_Definition (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Entity (Name (N)); + E : Entity_Id; + Old_Val : String_Id := Strval (Expr_Value_S (Expression (N))); + New_Val : String_Id; + + begin + + -- For the rep clause "for x'external_tag use y" generate: + + -- xV : constant string := y; + -- Set_External_Tag (x'tag, xV'Address); + -- Register_Tag (x'tag); + + -- note that register_tag has been delayed up to now because + -- the external_tag must be set before registering. + + -- Create a new nul terminated string if it is not already + + if String_Length (Old_Val) > 0 + and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 + then + New_Val := Old_Val; + else + Start_String (Old_Val); + Store_String_Char (Get_Char_Code (ASCII.NUL)); + New_Val := End_String; + end if; + + E := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Ent), 'A')); + + -- The generated actions must be elaborated at the subsequent + -- freeze point, not at the point of the attribute definition. + + Append_Freeze_Action (Ent, + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Strval => New_Val))); + + Append_Freeze_Actions (Ent, New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Tag, + Prefix => New_Occurrence_Of (Ent, Loc)), + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Occurrence_Of (E, Loc)))), + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Tag, + Prefix => New_Occurrence_Of (Ent, Loc)))))); + end Expand_External_Tag_Definition; + ---------------------------- -- Expand_N_Freeze_Entity -- ---------------------------- *************** package body Exp_Ch13 is *** 309,314 **** --- 319,340 ---- if Is_Enumeration_Type (E) then Build_Enumeration_Image_Tables (E, N); + + elsif Is_Tagged_Type (E) + and then Is_First_Subtype (E) + then + + -- Check for a definition of External_Tag, whose expansion must + -- be delayed until the dispatch table is built. + + declare + Def : Node_Id := + Get_Attribute_Definition_Clause (E, Attribute_External_Tag); + begin + if Present (Def) then + Expand_External_Tag_Definition (Def); + end if; + end; end if; -- If subprogram, freeze the subprogram diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch13.ads gcc-3.3/gcc/ada/exp_ch13.ads *** gcc-3.2.3/gcc/ada/exp_ch13.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch13.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch2.adb gcc-3.3/gcc/ada/exp_ch2.adb *** gcc-3.2.3/gcc/ada/exp_ch2.adb 2002-05-04 03:27:46.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch2.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** *** 29,34 **** --- 28,34 ---- with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; + with Errout; use Errout; with Exp_Smem; use Exp_Smem; with Exp_Util; use Exp_Util; with Exp_VFpt; use Exp_VFpt; *************** package body Exp_Ch2 is *** 210,215 **** --- 210,221 ---- E : constant Entity_Id := Entity (N); begin + -- Defend against errors + + if No (E) and then Total_Errors_Detected /= 0 then + return; + end if; + if Ekind (E) = E_Discriminant then Expand_Discriminant (N); diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch2.ads gcc-3.3/gcc/ada/exp_ch2.ads *** gcc-3.2.3/gcc/ada/exp_ch2.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch2.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch3.adb gcc-3.3/gcc/ada/exp_ch3.adb *** gcc-3.2.3/gcc/ada/exp_ch3.adb 2002-05-04 03:27:46.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch3.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Atree; use Atree; *** 30,35 **** --- 29,35 ---- with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; + with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch4; use Exp_Ch4; with Exp_Ch7; use Exp_Ch7; *************** package body Exp_Ch3 is *** 118,123 **** --- 118,128 ---- -- Create An Equality function for the non-tagged variant record 'Typ' -- and attach it to the TSS list + procedure Check_Stream_Attributes (Typ : Entity_Id); + -- Check that if a limited extension has a parent with user-defined + -- stream attributes, any limited component of the extension also has + -- the corresponding user-defined stream attributes. + procedure Expand_Tagged_Root (T : Entity_Id); -- Add a field _Tag at the beginning of the record. This field carries -- the value of the access to the Dispatch table. This procedure is only *************** package body Exp_Ch3 is *** 147,152 **** --- 152,161 ---- -- applies only to E_Record_Type entities, not to class wide types, -- record subtypes, or private types. + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); + -- Treat user-defined stream operations as renaming_as_body if the + -- subprogram they rename is not frozen when the type is frozen. + function Init_Formals (Typ : Entity_Id) return List_Id; -- This function builds the list of formals for an initialization routine. -- The first formal is always _Init with the given type. For task value *************** package body Exp_Ch3 is *** 561,567 **** Set_Ekind (Proc_Id, E_Procedure); Set_Is_Public (Proc_Id, Is_Public (A_Type)); - Set_Is_Inlined (Proc_Id); Set_Is_Internal (Proc_Id); Set_Has_Completion (Proc_Id); --- 570,575 ---- *************** package body Exp_Ch3 is *** 569,574 **** --- 577,593 ---- Set_Debug_Info_Off (Proc_Id); end if; + -- Set inlined unless controlled stuff or tasks around, in which + -- case we do not want to inline, because nested stuff may cause + -- difficulties in interunit inlining, and furthermore there is + -- in any case no point in inlining such complex init procs. + + if not Has_Task (Proc_Id) + and then not Controlled_Type (Proc_Id) + then + Set_Is_Inlined (Proc_Id); + end if; + -- Associate Init_Proc with type, and determine if the procedure -- is null (happens because of the Initialize_Scalars pragma case, -- where we have to generate a null procedure in case it is called *************** package body Exp_Ch3 is *** 1325,1338 **** -- of the initialization procedure (by calling all the preceding -- auxiliary routines), and install it as the _init TSS. ! procedure Build_Record_Checks ! (S : Node_Id; ! Related_Nod : Node_Id; ! Check_List : List_Id); -- Add range checks to components of disciminated records. S is a ! -- subtype indication of a record component. Related_Nod is passed ! -- for compatibility with Process_Range_Expr_In_Decl. Check_List is ! -- a list to which the check actions are appended. function Component_Needs_Simple_Initialization (T : Entity_Id) --- 1344,1353 ---- -- of the initialization procedure (by calling all the preceding -- auxiliary routines), and install it as the _init TSS. ! procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); -- Add range checks to components of disciminated records. S is a ! -- subtype indication of a record component. Check_List is a list ! -- to which the check actions are appended. function Component_Needs_Simple_Initialization (T : Entity_Id) *************** package body Exp_Ch3 is *** 1345,1364 **** -- initialized by other means. procedure Constrain_Array ! (SI : Node_Id; ! Related_Nod : Node_Id; ! Check_List : List_Id); -- Called from Build_Record_Checks. -- Apply a list of index constraints to an unconstrained array type. -- The first parameter is the entity for the resulting subtype. ! -- Related_Nod is passed for compatibility with Process_Range_Expr_In_ ! -- Decl. Check_List is a list to which the check actions are appended. procedure Constrain_Index ! (Index : Node_Id; ! S : Node_Id; ! Related_Nod : Node_Id; ! Check_List : List_Id); -- Called from Build_Record_Checks. -- Process an index constraint in a constrained array declaration. -- The constraint can be a subtype name, or a range with or without --- 1360,1376 ---- -- initialized by other means. procedure Constrain_Array ! (SI : Node_Id; ! Check_List : List_Id); -- Called from Build_Record_Checks. -- Apply a list of index constraints to an unconstrained array type. -- The first parameter is the entity for the resulting subtype. ! -- Check_List is a list to which the check actions are appended. procedure Constrain_Index ! (Index : Node_Id; ! S : Node_Id; ! Check_List : List_Id); -- Called from Build_Record_Checks. -- Process an index constraint in a constrained array declaration. -- The constraint can be a subtype name, or a range with or without *************** package body Exp_Ch3 is *** 1864,1873 **** Decl := First_Non_Pragma (Component_Items (Comp_List)); while Present (Decl) loop Loc := Sloc (Decl); ! Build_Record_Checks ! (Subtype_Indication (Decl), ! Decl, ! Check_List); Id := Defining_Identifier (Decl); Typ := Etype (Id); --- 1876,1882 ---- Decl := First_Non_Pragma (Component_Items (Comp_List)); while Present (Decl) loop Loc := Sloc (Decl); ! Build_Record_Checks (Subtype_Indication (Decl), Check_List); Id := Defining_Identifier (Decl); Typ := Etype (Id); *************** package body Exp_Ch3 is *** 2065,2079 **** -- Build_Record_Checks -- ------------------------- ! procedure Build_Record_Checks ! (S : Node_Id; ! Related_Nod : Node_Id; ! Check_List : List_Id) ! is P : Node_Id; Subtype_Mark_Id : Entity_Id; - begin if Nkind (S) = N_Subtype_Indication then Find_Type (Subtype_Mark (S)); P := Parent (S); --- 2074,2084 ---- -- Build_Record_Checks -- ------------------------- ! procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is P : Node_Id; Subtype_Mark_Id : Entity_Id; + begin if Nkind (S) = N_Subtype_Indication then Find_Type (Subtype_Mark (S)); P := Parent (S); *************** package body Exp_Ch3 is *** 2084,2096 **** case Ekind (Subtype_Mark_Id) is when Array_Kind => ! Constrain_Array (S, Related_Nod, Check_List); when others => null; end case; end if; - end Build_Record_Checks; ------------------------------------------- --- 2089,2100 ---- case Ekind (Subtype_Mark_Id) is when Array_Kind => ! Constrain_Array (S, Check_List); when others => null; end case; end if; end Build_Record_Checks; ------------------------------------------- *************** package body Exp_Ch3 is *** 2114,2120 **** procedure Constrain_Array (SI : Node_Id; - Related_Nod : Node_Id; Check_List : List_Id) is C : constant Node_Id := Constraint (SI); --- 2118,2123 ---- *************** package body Exp_Ch3 is *** 2148,2154 **** -- Apply constraints to each index type for J in 1 .. Number_Of_Constraints loop ! Constrain_Index (Index, S, Related_Nod, Check_List); Next (Index); Next (S); end loop; --- 2151,2157 ---- -- Apply constraints to each index type for J in 1 .. Number_Of_Constraints loop ! Constrain_Index (Index, S, Check_List); Next (Index); Next (S); end loop; *************** package body Exp_Ch3 is *** 2162,2175 **** procedure Constrain_Index (Index : Node_Id; S : Node_Id; - Related_Nod : Node_Id; Check_List : List_Id) is T : constant Entity_Id := Etype (Index); begin if Nkind (S) = N_Range then ! Process_Range_Expr_In_Decl (S, T, Related_Nod, Check_List); end if; end Constrain_Index; --- 2165,2177 ---- procedure Constrain_Index (Index : Node_Id; S : Node_Id; Check_List : List_Id) is T : constant Entity_Id := Etype (Index); begin if Nkind (S) = N_Range then ! Process_Range_Expr_In_Decl (S, T, Check_List); end if; end Constrain_Index; *************** package body Exp_Ch3 is *** 2376,2383 **** -- yet. The initialization of controlled records contains a nested -- clean-up procedure that makes it impractical to inline as well, -- and leads to undefined symbols if inlined in a different unit. ! if not Is_Protected_Record_Type (Rec_Type) and then not Controlled_Type (Rec_Type) then Set_Is_Inlined (Proc_Id); --- 2378,2387 ---- -- yet. The initialization of controlled records contains a nested -- clean-up procedure that makes it impractical to inline as well, -- and leads to undefined symbols if inlined in a different unit. + -- Similar considerations apply to task types. ! if not Is_Concurrent_Type (Rec_Type) ! and then not Has_Task (Rec_Type) and then not Controlled_Type (Rec_Type) then Set_Is_Inlined (Proc_Id); *************** package body Exp_Ch3 is *** 2482,2489 **** if Has_Unchecked_Union (Typ) then Append_To (Stmts, ! Make_Raise_Program_Error (Loc)); ! else Append_To (Stmts, Make_Eq_If (Typ, --- 2486,2493 ---- if Has_Unchecked_Union (Typ) then Append_To (Stmts, ! Make_Raise_Program_Error (Loc, ! Reason => PE_Unchecked_Union_Restriction)); else Append_To (Stmts, Make_Eq_If (Typ, *************** package body Exp_Ch3 is *** 2504,2509 **** --- 2508,2548 ---- end if; end Build_Variant_Record_Equality; + ----------------------------- + -- Check_Stream_Attributes -- + ----------------------------- + + procedure Check_Stream_Attributes (Typ : Entity_Id) is + Comp : Entity_Id; + Par : constant Entity_Id := Root_Type (Base_Type (Typ)); + Par_Read : Boolean := Present (TSS (Par, Name_uRead)); + Par_Write : Boolean := Present (TSS (Par, Name_uWrite)); + + begin + if Par_Read or else Par_Write then + Comp := First_Component (Typ); + while Present (Comp) loop + if Comes_From_Source (Comp) + and then Original_Record_Component (Comp) = Comp + and then Is_Limited_Type (Etype (Comp)) + then + if (Par_Read and then + No (TSS (Base_Type (Etype (Comp)), Name_uRead))) + or else + (Par_Write and then + No (TSS (Base_Type (Etype (Comp)), Name_uWrite))) + then + Error_Msg_N + ("|component must have Stream attribute", + Parent (Comp)); + end if; + end if; + + Next_Component (Comp); + end loop; + end if; + end Check_Stream_Attributes; + --------------------------- -- Expand_Derived_Record -- --------------------------- *************** package body Exp_Ch3 is *** 2679,2685 **** end if; elsif Has_Task (Def_Id) then ! Expand_Previous_Access_Type (N, Def_Id); end if; Par_Id := Etype (B_Id); --- 2718,2724 ---- end if; elsif Has_Task (Def_Id) then ! Expand_Previous_Access_Type (Def_Id); end if; Par_Id := Etype (B_Id); *************** package body Exp_Ch3 is *** 2757,2766 **** Expr_Q : Node_Id; begin -- Don't do anything for deferred constants. All proper actions will -- be expanded during the redeclaration. ! if No (Expr) and Constant_Present (N) then return; end if; --- 2796,2814 ---- Expr_Q : Node_Id; begin + -- If we have a task type in no run time mode, then complain and ignore + + if No_Run_Time + and then not Restricted_Profile + and then Is_Task_Type (Typ) + then + Disallow_In_No_Run_Time_Mode (N); + return; + -- Don't do anything for deferred constants. All proper actions will -- be expanded during the redeclaration. ! elsif No (Expr) and Constant_Present (N) then return; end if; *************** package body Exp_Ch3 is *** 2870,2875 **** --- 2918,2931 ---- Insert_Actions_After (N, Build_Initialization_Call (Loc, Id_Ref, Typ)); + -- The initialization call may well set Not_Source_Assigned + -- to False, because it looks like an modification, but the + -- proper criterion is whether or not the type is at least + -- partially initialized, so reset the flag appropriately. + + Set_Not_Source_Assigned + (Def_Id, not Is_Partially_Initialized_Type (Typ)); + -- If simple initialization is required, then set an appropriate -- simple initialization expression in place. This special -- initialization is required even though No_Init_Flag is present. *************** package body Exp_Ch3 is *** 3076,3082 **** -- Expand_Previous_Access_Type -- --------------------------------- ! procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id) is T : Entity_Id := First_Entity (Current_Scope); begin --- 3132,3138 ---- -- Expand_Previous_Access_Type -- --------------------------------- ! procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is T : Entity_Id := First_Entity (Current_Scope); begin *************** package body Exp_Ch3 is *** 3456,3462 **** Discrete_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( Make_Raise_Program_Error (Loc, ! Condition => Make_Identifier (Loc, Name_uF)), Make_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, -1))))); --- 3512,3519 ---- Discrete_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( Make_Raise_Program_Error (Loc, ! Condition => Make_Identifier (Loc, Name_uF), ! Reason => PE_Invalid_Data), Make_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, -1))))); *************** package body Exp_Ch3 is *** 3568,3573 **** --- 3625,3637 ---- end; end if; + if Is_Derived_Type (Def_Id) + and then Is_Limited_Type (Def_Id) + and then Is_Tagged_Type (Def_Id) + then + Check_Stream_Attributes (Def_Id); + end if; + -- Update task and controlled component flags, because some of the -- component types may have been private at the point of the record -- declaration. *************** package body Exp_Ch3 is *** 3760,3765 **** --- 3824,3863 ---- end Freeze_Record_Type; + ------------------------------ + -- Freeze_Stream_Operations -- + ------------------------------ + + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is + Names : constant array (1 .. 4) of Name_Id := + (Name_uInput, Name_uOutput, Name_uRead, Name_uWrite); + Stream_Op : Entity_Id; + + begin + -- Primitive operations of tagged types are frozen when the dispatch + -- table is constructed. + + if not Comes_From_Source (Typ) + or else Is_Tagged_Type (Typ) + then + return; + end if; + + for J in Names'Range loop + Stream_Op := TSS (Typ, Names (J)); + + if Present (Stream_Op) + and then Is_Subprogram (Stream_Op) + and then Nkind (Unit_Declaration_Node (Stream_Op)) = + N_Subprogram_Declaration + and then not Is_Frozen (Stream_Op) + then + Append_Freeze_Actions + (Typ, Freeze_Entity (Stream_Op, Sloc (N))); + end if; + end loop; + end Freeze_Stream_Operations; + ----------------- -- Freeze_Type -- ----------------- *************** package body Exp_Ch3 is *** 3974,3980 **** -- Third discriminant is the alignment DT_Align))))); - end; Set_Associated_Storage_Pool (Def_Id, Pool_Object); --- 4072,4077 ---- *************** package body Exp_Ch3 is *** 3990,3996 **** -- when analyzing the rep. clause null; - end if; -- For access-to-controlled types (including class-wide types --- 4087,4092 ---- *************** package body Exp_Ch3 is *** 4078,4083 **** --- 4174,4181 ---- -- the freeze nodes are there for use by Gigi. end if; + + Freeze_Stream_Operations (N, Def_Id); end Freeze_Type; ------------------------- *************** package body Exp_Ch3 is *** 4095,4103 **** Val_RE : RE_Id; begin -- For scalars, we must have normalize/initialize scalars case ! if Is_Scalar_Type (T) then pragma Assert (Init_Or_Norm_Scalars); -- Processing for Normalize_Scalars case --- 4193,4226 ---- Val_RE : RE_Id; begin + -- For a private type, we should always have an underlying type + -- (because this was already checked in Needs_Simple_Initialization). + -- What we do is to get the value for the underlying type and then + -- do an Unchecked_Convert to the private type. + + if Is_Private_Type (T) then + Val := Get_Simple_Init_Val (Underlying_Type (T), Loc); + + -- A special case, if the underlying value is null, then qualify + -- it with the underlying type, so that the null is properly typed + -- Similarly, if it is an aggregate it must be qualified, because + -- an unchecked conversion does not provide a context for it. + + if Nkind (Val) = N_Null + or else Nkind (Val) = N_Aggregate + then + Val := + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Type (T), Loc), + Expression => Val); + end if; + + return Unchecked_Convert_To (T, Val); + -- For scalars, we must have normalize/initialize scalars case ! elsif Is_Scalar_Type (T) then pragma Assert (Init_Or_Norm_Scalars); -- Processing for Normalize_Scalars case *************** package body Exp_Ch3 is *** 4248,4280 **** return Nod; end; ! -- Otherwise we have a case of a private type whose underlying type ! -- needs simple initialization. In this case, we get the value for ! -- the underlying type, then unchecked convert to the private type. else ! pragma Assert ! (Is_Private_Type (T) ! and then Present (Underlying_Type (T))); ! ! Val := Get_Simple_Init_Val (Underlying_Type (T), Loc); ! ! -- A special case, if the underlying value is null, then qualify ! -- it with the underlying type, so that the null is properly typed ! -- Similarly, if it is an aggregate it must be qualified, because ! -- an unchecked conversion does not provide a context for it. ! ! if Nkind (Val) = N_Null ! or else Nkind (Val) = N_Aggregate ! then ! Val := ! Make_Qualified_Expression (Loc, ! Subtype_Mark => ! New_Occurrence_Of (Underlying_Type (T), Loc), ! Expression => Val); ! end if; ! ! return Unchecked_Convert_To (T, Val); end if; end Get_Simple_Init_Val; --- 4371,4382 ---- return Nod; end; ! -- No other possibilities should arise, since we should only be ! -- calling Get_Simple_Init_Val if Needs_Simple_Initialization ! -- returned True, indicating one of the above cases held. else ! raise Program_Error; end if; end Get_Simple_Init_Val; *************** package body Exp_Ch3 is *** 4718,4728 **** function Needs_Simple_Initialization (T : Entity_Id) return Boolean is begin -- Cases needing simple initialization are access types, and, if pragma -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar -- types. ! if Is_Access_Type (T) or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) or else (Is_Bit_Packed_Array (T) --- 4820,4845 ---- function Needs_Simple_Initialization (T : Entity_Id) return Boolean is begin + -- Check for private type, in which case test applies to the + -- underlying type of the private type. + + if Is_Private_Type (T) then + declare + RT : constant Entity_Id := Underlying_Type (T); + + begin + if Present (RT) then + return Needs_Simple_Initialization (RT); + else + return False; + end if; + end; + -- Cases needing simple initialization are access types, and, if pragma -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar -- types. ! elsif Is_Access_Type (T) or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) or else (Is_Bit_Packed_Array (T) *************** package body Exp_Ch3 is *** 4745,4765 **** then return True; - -- Check for private type, in which case test applies to the - -- underlying type of the private type. - - elsif Is_Private_Type (T) then - declare - RT : constant Entity_Id := Underlying_Type (T); - - begin - if Present (RT) then - return Needs_Simple_Initialization (RT); - else - return False; - end if; - end; - else return False; end if; --- 4862,4867 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch3.ads gcc-3.3/gcc/ada/exp_ch3.ads *** gcc-3.2.3/gcc/ada/exp_ch3.ads 2002-05-04 03:27:46.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch3.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package Exp_Ch3 is *** 38,45 **** procedure Expand_N_Variant_Part (N : Node_Id); procedure Expand_N_Full_Type_Declaration (N : Node_Id); ! procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id); ! -- For a full type declaration that contains tasks, or that is a task, -- check whether there exists an access type whose designated type is an -- incomplete declarations for the current composite type. If so, build -- the master for that access type, now that it is known to denote an --- 37,44 ---- procedure Expand_N_Variant_Part (N : Node_Id); procedure Expand_N_Full_Type_Declaration (N : Node_Id); ! procedure Expand_Previous_Access_Type (Def_Id : Entity_Id); ! -- For a full type declaration that contains tasks, or that is a task, -- check whether there exists an access type whose designated type is an -- incomplete declarations for the current composite type. If so, build -- the master for that access type, now that it is known to denote an diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch4.adb gcc-3.3/gcc/ada/exp_ch4.adb *** gcc-3.2.3/gcc/ada/exp_ch4.adb 2002-05-04 03:27:48.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch4.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.4.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Inline; use Inline; *** 46,51 **** --- 45,51 ---- with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; + with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Cat; use Sem_Cat; *************** with Sem_Eval; use Sem_Eval; *** 54,63 **** --- 54,65 ---- with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; + with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinfo.CN; use Sinfo.CN; with Snames; use Snames; with Stand; use Stand; + with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; *************** package body Exp_Ch4 is *** 1298,1308 **** end if; -- If we have anything other than Standard_Character or ! -- Standard_String, then we must have had an error earlier. ! -- So we just abandon the attempt at expansion. else ! pragma Assert (Errors_Detected > 0); return; end if; --- 1300,1310 ---- end if; -- If we have anything other than Standard_Character or ! -- Standard_String, then we must have had a serious error ! -- earlier, so we just abandon the attempt at expansion. else ! pragma Assert (Serious_Errors_Detected > 0); return; end if; *************** package body Exp_Ch4 is *** 1649,1658 **** if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then ! -- Propagate constraint_error to enclosing allocator. ! Rewrite ! (Exp, New_Copy (Expression (Exp))); end if; else -- First check against the type of the qualified expression --- 1651,1659 ---- if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then ! -- Propagate constraint_error to enclosing allocator ! Rewrite (Exp, New_Copy (Expression (Exp))); end if; else -- First check against the type of the qualified expression *************** package body Exp_Ch4 is *** 2572,2578 **** -- Deal with software overflow checking ! if Software_Overflow_Checking and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then --- 2573,2579 ---- -- Deal with software overflow checking ! if not Backend_Overflow_Checks_On_Target and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then *************** package body Exp_Ch4 is *** 3069,3074 **** --- 3070,3076 ---- Typ : constant Entity_Id := Etype (N); Rtyp : constant Entity_Id := Root_Type (Typ); Base : constant Node_Id := Relocate_Node (Left_Opnd (N)); + Bastyp : constant Node_Id := Etype (Base); Exp : constant Node_Id := Relocate_Node (Right_Opnd (N)); Exptyp : constant Entity_Id := Etype (Exp); Ovflo : constant Boolean := Do_Overflow_Check (N); *************** package body Exp_Ch4 is *** 3081,3086 **** --- 3083,3118 ---- begin Binary_Op_Validity_Checks (N); + -- If either operand is of a private type, then we have the use of + -- an intrinsic operator, and we get rid of the privateness, by using + -- root types of underlying types for the actual operation. Otherwise + -- the private types will cause trouble if we expand multiplications + -- or shifts etc. We also do this transformation if the result type + -- is different from the base type. + + if Is_Private_Type (Etype (Base)) + or else + Is_Private_Type (Typ) + or else + Is_Private_Type (Exptyp) + or else + Rtyp /= Root_Type (Bastyp) + then + declare + Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); + Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); + + begin + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Op_Expon (Loc, + Left_Opnd => Unchecked_Convert_To (Bt, Base), + Right_Opnd => Unchecked_Convert_To (Et, Exp)))); + Analyze_And_Resolve (N, Typ); + return; + end; + end if; + -- At this point the exponentiation must be dynamic since the static -- case has already been folded after Resolve by Eval_Op_Expon. *************** package body Exp_Ch4 is *** 3201,3209 **** end; end if; ! -- Fall through if exponentiation must be done using a runtime routine. ! -- First deal with modular case. if Is_Modular_Integer_Type (Rtyp) then --- 3233,3246 ---- end; end if; ! -- Fall through if exponentiation must be done using a runtime routine ! if No_Run_Time then ! Disallow_In_No_Run_Time_Mode (N); ! return; ! end if; ! ! -- First deal with modular case if Is_Modular_Integer_Type (Rtyp) then *************** package body Exp_Ch4 is *** 3496,3502 **** begin Unary_Op_Validity_Checks (N); ! if Software_Overflow_Checking and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then --- 3533,3539 ---- begin Unary_Op_Validity_Checks (N); ! if not Backend_Overflow_Checks_On_Target and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then *************** package body Exp_Ch4 is *** 4738,4762 **** Expression => Conv), Make_Raise_Constraint_Error (Loc, ! Condition => ! Make_Or_Else (Loc, ! Left_Opnd => ! Make_Op_Lt (Loc, ! Left_Opnd => New_Occurrence_Of (Tnn, Loc), ! Right_Opnd => ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_First, ! Prefix => ! New_Occurrence_Of (Target_Type, Loc))), ! Right_Opnd => ! Make_Op_Gt (Loc, ! Left_Opnd => New_Occurrence_Of (Tnn, Loc), ! Right_Opnd => ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Last, ! Prefix => ! New_Occurrence_Of (Target_Type, Loc))))))); Rewrite (N, New_Occurrence_Of (Tnn, Loc)); Analyze_And_Resolve (N, Btyp); --- 4775,4800 ---- Expression => Conv), Make_Raise_Constraint_Error (Loc, ! Condition => ! Make_Or_Else (Loc, ! Left_Opnd => ! Make_Op_Lt (Loc, ! Left_Opnd => New_Occurrence_Of (Tnn, Loc), ! Right_Opnd => ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_First, ! Prefix => ! New_Occurrence_Of (Target_Type, Loc))), ! Right_Opnd => ! Make_Op_Gt (Loc, ! Left_Opnd => New_Occurrence_Of (Tnn, Loc), ! Right_Opnd => ! Make_Attribute_Reference (Loc, ! Attribute_Name => Name_Last, ! Prefix => ! New_Occurrence_Of (Target_Type, Loc)))), ! Reason => CE_Range_Check_Failed))); Rewrite (N, New_Occurrence_Of (Tnn, Loc)); Analyze_And_Resolve (N, Btyp); *************** package body Exp_Ch4 is *** 4826,4835 **** -- cases. elsif In_Instance_Body ! and then Type_Access_Level (Operand_Type) ! > Type_Access_Level (Target_Type) then ! Rewrite (N, Make_Raise_Program_Error (Sloc (N))); Set_Etype (N, Target_Type); -- When the operand is a selected access discriminant --- 4864,4875 ---- -- cases. elsif In_Instance_Body ! and then Type_Access_Level (Operand_Type) > ! Type_Access_Level (Target_Type) then ! Rewrite (N, ! Make_Raise_Program_Error (Sloc (N), ! Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Target_Type); -- When the operand is a selected access discriminant *************** package body Exp_Ch4 is *** 4845,4851 **** and then Object_Access_Level (Operand) > Type_Access_Level (Target_Type) then ! Rewrite (N, Make_Raise_Program_Error (Sloc (N))); Set_Etype (N, Target_Type); end if; end if; --- 4885,4893 ---- and then Object_Access_Level (Operand) > Type_Access_Level (Target_Type) then ! Rewrite (N, ! Make_Raise_Program_Error (Sloc (N), ! Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Target_Type); end if; end if; *************** package body Exp_Ch4 is *** 4936,4942 **** Insert_Action (N, Make_Raise_Constraint_Error (Loc, ! Condition => Cond)); Change_Conversion_To_Unchecked (N); Analyze_And_Resolve (N, Target_Type); --- 4978,4985 ---- Insert_Action (N, Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Tag_Check_Failed)); Change_Conversion_To_Unchecked (N); Analyze_And_Resolve (N, Target_Type); *************** package body Exp_Ch4 is *** 5310,5322 **** -- statement directly. if No (Parent (Lhs)) then ! Result := Make_Raise_Program_Error (Loc); Set_Etype (Result, Standard_Boolean); return Result; else Insert_Action (Lhs, ! Make_Raise_Program_Error (Loc)); return New_Occurrence_Of (Standard_True, Loc); end if; end if; --- 5353,5368 ---- -- statement directly. if No (Parent (Lhs)) then ! Result := ! Make_Raise_Program_Error (Loc, ! Reason => PE_Unchecked_Union_Restriction); Set_Etype (Result, Standard_Boolean); return Result; else Insert_Action (Lhs, ! Make_Raise_Program_Error (Loc, ! Reason => PE_Unchecked_Union_Restriction)); return New_Occurrence_Of (Standard_True, Loc); end if; end if; *************** package body Exp_Ch4 is *** 5919,5929 **** --- 5965,5977 ---- Rewrite (N, Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N)))); Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); elsif False_Result then Rewrite (N, Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N)))); Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); end if; end Rewrite_Comparison; diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch4.ads gcc-3.3/gcc/ada/exp_ch4.ads *** gcc-3.2.3/gcc/ada/exp_ch4.ads 2002-05-04 03:27:49.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch4.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch5.adb gcc-3.3/gcc/ada/exp_ch5.adb *** gcc-3.2.3/gcc/ada/exp_ch5.adb 2002-05-04 03:27:50.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch5.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.4.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Exp_Ch5 is *** 311,322 **** -- Note: overlap is never possible if there is a change of -- representation, so we can exclude this case - -- In the case of compiling for the Java Virtual Machine, - -- slices are always passed by making a copy, so we don't - -- have to worry about overlap. We also want to prevent - -- generation of "<" comparisons for array addresses, - -- since that's a meaningless operation on the JVM. - if Ndim = 1 and then not Crep and then --- 310,315 ---- *************** package body Exp_Ch5 is *** 325,330 **** --- 318,330 ---- (Lhs_Formal and Rhs_Non_Local_Var) or else (Rhs_Formal and Lhs_Non_Local_Var)) + + -- In the case of compiling for the Java Virtual Machine, + -- slices are always passed by making a copy, so we don't + -- have to worry about overlap. We also want to prevent + -- generation of "<" comparisons for array addresses, + -- since that's a meaningless operation on the JVM. + and then not Java_VM then Set_Forwards_OK (N, False); *************** package body Exp_Ch5 is *** 352,366 **** elsif Has_Controlled_Component (L_Type) then Loop_Required := True; ! -- The only remaining cases involve slice assignments. If no slices ! -- are involved, then the assignment can definitely be handled by gigi. ! -- unless we have the parameter case mentioned above. elsif not L_Slice and not R_Slice then ! -- The following is temporary code??? It is not clear why it is ! -- necessary. For further investigation, look at the following ! -- short program which fails: -- procedure C52 is -- type BITS is array(INTEGER range <>) of BOOLEAN; --- 352,375 ---- elsif Has_Controlled_Component (L_Type) then Loop_Required := True; ! -- Case where no slice is involved elsif not L_Slice and not R_Slice then ! -- The following code deals with the case of unconstrained bit ! -- packed arrays. The problem is that the template for such ! -- arrays contains the bounds of the actual source level array, ! ! -- But the copy of an entire array requires the bounds of the ! -- underlying array. It would be nice if the back end could take ! -- care of this, but right now it does not know how, so if we ! -- have such a type, then we expand out into a loop, which is ! -- inefficient but works correctly. If we don't do this, we ! -- get the wrong length computed for the array to be moved. ! -- The two cases we need to worry about are: ! ! -- Explicit deference of an unconstrained packed array type as ! -- in the following example: -- procedure C52 is -- type BITS is array(INTEGER range <>) of BOOLEAN; *************** package body Exp_Ch5 is *** 373,394 **** -- P2.ALL := P1.ALL; -- end C52; ! -- To deal with the above, we expand out if either of the operands ! -- is an explicit dereference to an unconstrained bit packed array. ! Temporary_Code : declare ! function Is_Deref_Of_UBP (Opnd : Node_Id) return Boolean; ! -- Function to perform required test for special case above ! function Is_Deref_Of_UBP (Opnd : Node_Id) return Boolean is P_Type : Entity_Id; Des_Type : Entity_Id; begin ! if Nkind (Opnd) /= N_Explicit_Dereference then ! return False; ! else ! P_Type := Etype (Prefix (Opnd)); if not Is_Access_Type (P_Type) then return False; --- 382,426 ---- -- P2.ALL := P1.ALL; -- end C52; ! -- A formal parameter reference with an unconstrained bit ! -- array type is the other case we need to worry about (here ! -- we assume the same BITS type declared above: ! -- procedure Write_All (File : out BITS; Contents : in BITS); ! -- begin ! -- File.Storage := Contents; ! -- end Write_All; ! -- We expand to a loop in either of these two cases. ! ! -- Question for future thought. Another potentially more efficient ! -- approach would be to create the actual subtype, and then do an ! -- unchecked conversion to this actual subtype ??? ! ! Check_Unconstrained_Bit_Packed_Array : declare ! ! function Is_UBPA_Reference (Opnd : Node_Id) return Boolean; ! -- Function to perform required test for the first case, ! -- above (dereference of an unconstrained bit packed array) ! ! ----------------------- ! -- Is_UBPA_Reference -- ! ----------------------- ! ! function Is_UBPA_Reference (Opnd : Node_Id) return Boolean is ! Typ : constant Entity_Id := Underlying_Type (Etype (Opnd)); P_Type : Entity_Id; Des_Type : Entity_Id; begin ! if Present (Packed_Array_Type (Typ)) ! and then Is_Array_Type (Packed_Array_Type (Typ)) ! and then not Is_Constrained (Packed_Array_Type (Typ)) ! then ! return True; ! ! elsif Nkind (Opnd) = N_Explicit_Dereference then ! P_Type := Underlying_Type (Etype (Prefix (Opnd))); if not Is_Access_Type (P_Type) then return False; *************** package body Exp_Ch5 is *** 399,422 **** Is_Bit_Packed_Array (Des_Type) and then not Is_Constrained (Des_Type); end if; end if; ! end Is_Deref_Of_UBP; ! -- Start of processing for temporary code begin ! if Is_Deref_Of_UBP (Lhs) or else ! Is_Deref_Of_UBP (Rhs) then Loop_Required := True; ! -- Normal case (will be only case when above temp code removed ??? elsif Forwards_OK (N) then return; end if; ! end Temporary_Code; -- Gigi can always handle the assignment if the right side is a string -- literal (note that overlap is definitely impossible in this case). --- 431,462 ---- Is_Bit_Packed_Array (Des_Type) and then not Is_Constrained (Des_Type); end if; + + else + return False; end if; ! end Is_UBPA_Reference; ! -- Start of processing for Check_Unconstrained_Bit_Packed_Array begin ! if Is_UBPA_Reference (Lhs) or else ! Is_UBPA_Reference (Rhs) then Loop_Required := True; ! -- Here if we do not have the case of a reference to a bit ! -- packed unconstrained array case. In this case gigi can ! -- most certainly handle the assignment if a forwards move ! -- is allowed. ! ! -- (could it handle the backwards case also???) elsif Forwards_OK (N) then return; end if; ! end Check_Unconstrained_Bit_Packed_Array; -- Gigi can always handle the assignment if the right side is a string -- literal (note that overlap is definitely impossible in this case). *************** package body Exp_Ch5 is *** 1498,1504 **** Exception_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( ! Make_Raise_Program_Error (Loc))))))); end if; end if; --- 1538,1547 ---- Exception_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( ! Make_Raise_Program_Error (Loc, ! Reason => ! PE_Finalize_Raised_Exception) ! )))))); end if; end if; *************** package body Exp_Ch5 is *** 2378,2384 **** Right_Opnd => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To ! (Access_Disp_Table (Base_Type (Utyp)), Loc))))); -- If the result type is a specific nonlimited tagged type, -- then we have to ensure that the tag of the result is that --- 2421,2428 ---- Right_Opnd => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To ! (Access_Disp_Table (Base_Type (Utyp)), Loc))), ! Reason => CE_Tag_Check_Failed)); -- If the result type is a specific nonlimited tagged type, -- then we have to ensure that the tag of the result is that *************** package body Exp_Ch5 is *** 2716,2728 **** and then No_Initialization (Parent (Entity (Expression (L)))) then null; - - elsif Nkind (L) = N_Indexed_Component - and then Is_Entity_Name (Original_Node (Prefix (L))) - and then Is_Entry_Formal (Entity (Original_Node (Prefix (L)))) - then - null; - else Append_List_To (Res, Make_Final_Call ( --- 2760,2765 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch5.ads gcc-3.3/gcc/ada/exp_ch5.ads *** gcc-3.2.3/gcc/ada/exp_ch5.ads 2002-05-04 03:27:51.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch5.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch6.adb gcc-3.3/gcc/ada/exp_ch6.adb *** gcc-3.2.3/gcc/ada/exp_ch6.adb 2002-05-04 03:27:51.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch6.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.4.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Exp_Ch6 is *** 464,470 **** Make_If_Statement (Loc, Condition => Test, Then_Statements => New_List ( ! Make_Raise_Storage_Error (Loc)), Else_Statements => New_List ( Relocate_Node (Node (Call))))); --- 463,470 ---- Make_If_Statement (Loc, Condition => Test, Then_Statements => New_List ( ! Make_Raise_Storage_Error (Loc, ! Reason => SE_Infinite_Recursion)), Else_Statements => New_List ( Relocate_Node (Node (Call))))); *************** package body Exp_Ch6 is *** 1208,1213 **** --- 1208,1219 ---- -- Start of processing for Expand_Call begin + -- Ignore if previous error + + if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then + return; + end if; + -- Call using access to subprogram with explicit dereference if Nkind (Name (N)) = N_Explicit_Dereference then *************** package body Exp_Ch6 is *** 1474,1480 **** Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Prev), Right_Opnd => Make_Null (Loc)); ! Insert_Action (Prev, Make_Raise_Constraint_Error (Loc, Cond)); end if; -- Perform appropriate validity checks on parameters --- 1480,1489 ---- Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Prev), Right_Opnd => Make_Null (Loc)); ! Insert_Action (Prev, ! Make_Raise_Constraint_Error (Loc, ! Condition => Cond, ! Reason => CE_Access_Parameter_Is_Null)); end if; -- Perform appropriate validity checks on parameters *************** package body Exp_Ch6 is *** 1678,1683 **** --- 1687,1693 ---- if Etype (Formal) /= Etype (Parent_Formal) and then Is_Scalar_Type (Etype (Formal)) and then Ekind (Formal) = E_In_Parameter + and then not Raises_Constraint_Error (Actual) then Rewrite (Actual, OK_Convert_To (Etype (Parent_Formal), *************** package body Exp_Ch6 is *** 2169,2175 **** -- use a qualified expression, because an aggregate is not a -- legal argument of a conversion. ! if Nkind (Expression (N)) = N_Aggregate then Ret := Make_Qualified_Expression (Sloc (N), Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), --- 2179,2187 ---- -- use a qualified expression, because an aggregate is not a -- legal argument of a conversion. ! if Nkind (Expression (N)) = N_Aggregate ! or else Nkind (Expression (N)) = N_Null ! then Ret := Make_Qualified_Expression (Sloc (N), Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), *************** package body Exp_Ch6 is *** 2876,2882 **** Make_Block_Statement (Hloc, Handled_Statement_Sequence => H); Rais : constant Node_Id := ! Make_Raise_Program_Error (Hloc); begin Set_Handled_Statement_Sequence (N, --- 2888,2895 ---- Make_Block_Statement (Hloc, Handled_Statement_Sequence => H); Rais : constant Node_Id := ! Make_Raise_Program_Error (Hloc, ! Reason => PE_Missing_Return); begin Set_Handled_Statement_Sequence (N, *************** package body Exp_Ch6 is *** 2912,2918 **** if Present (Next_Op) then Dec := Parent (Base_Type (Scop)); Set_Privals (Dec, Next_Op, Loc); ! Set_Discriminals (Dec, Next_Op, Loc); end if; end if; --- 2925,2931 ---- if Present (Next_Op) then Dec := Parent (Base_Type (Scop)); Set_Privals (Dec, Next_Op, Loc); ! Set_Discriminals (Dec); end if; end if; diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch6.ads gcc-3.3/gcc/ada/exp_ch6.ads *** gcc-3.2.3/gcc/ada/exp_ch6.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch6.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch7.adb gcc-3.3/gcc/ada/exp_ch7.adb *** gcc-3.2.3/gcc/ada/exp_ch7.adb 2002-05-04 03:27:52.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch7.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.4.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Exp_Ch7 is *** 380,401 **** ---------------------- procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is ! Loc : constant Source_Ptr := Sloc (N); begin Set_Associated_Final_Chain (Typ, Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'L'))); ! Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Associated_Final_Chain (Typ), Object_Definition => New_Reference_To ! (RTE (RE_List_Controller), Loc))); end Build_Final_List; ----------------------------- -- Build_Record_Deep_Procs -- ----------------------------- --- 379,434 ---- ---------------------- procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Decl : Node_Id; begin Set_Associated_Final_Chain (Typ, Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'L'))); ! Decl := Make_Object_Declaration (Loc, Defining_Identifier => Associated_Final_Chain (Typ), Object_Definition => New_Reference_To ! (RTE (RE_List_Controller), Loc)); ! ! -- The type may have been frozen already, and this is a late ! -- freezing action, in which case the declaration must be elaborated ! -- at once. If the call is for an allocator, the chain must also be ! -- created now, because the freezing of the type does not build one. ! -- Otherwise, the declaration is one of the freezing actions for a ! -- user-defined type. ! ! if Is_Frozen (Typ) ! or else (Nkind (N) = N_Allocator ! and then Ekind (Etype (N)) = E_Anonymous_Access_Type) ! then ! Insert_Action (N, Decl); ! else ! Append_Freeze_Action (Typ, Decl); ! end if; end Build_Final_List; + --------------------- + -- Build_Late_Proc -- + --------------------- + + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is + begin + for Final_Prim in Name_Of'Range loop + if Name_Of (Final_Prim) = Nam then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Final_Prim, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); + end if; + end loop; + end Build_Late_Proc; + ----------------------------- -- Build_Record_Deep_Procs -- ----------------------------- *************** package body Exp_Ch7 is *** 428,445 **** --------------------- function Controlled_Type (T : Entity_Id) return Boolean is begin ! -- Class-wide types are considered controlled because they may contain ! -- an extension that has controlled components return (Is_Class_Wide_Type (T) and then not No_Run_Time and then not In_Finalization_Root (T)) or else Is_Controlled (T) ! or else Has_Controlled_Component (T) or else (Is_Concurrent_Type (T) ! and then Present (Corresponding_Record_Type (T)) ! and then Controlled_Type (Corresponding_Record_Type (T))); end Controlled_Type; -------------------------- --- 461,525 ---- --------------------- function Controlled_Type (T : Entity_Id) return Boolean is + + function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; + -- If type is not frozen yet, check explicitly among its components, + -- because flag is not necessarily set. + + ------------------------------------ + -- Has_Some_Controlled_Component -- + ------------------------------------ + + function Has_Some_Controlled_Component (Rec : Entity_Id) + return Boolean + is + Comp : Entity_Id; + + begin + if Has_Controlled_Component (Rec) then + return True; + + elsif not Is_Frozen (Rec) then + if Is_Record_Type (Rec) then + Comp := First_Entity (Rec); + + while Present (Comp) loop + if not Is_Type (Comp) + and then Controlled_Type (Etype (Comp)) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + + elsif Is_Array_Type (Rec) then + return Is_Controlled (Component_Type (Rec)); + + else + return Has_Controlled_Component (Rec); + end if; + else + return False; + end if; + end Has_Some_Controlled_Component; + + -- Start of processing for Controlled_Type + begin ! -- Class-wide types must be treated as controlled because they may ! -- contain an extension that has controlled components return (Is_Class_Wide_Type (T) and then not No_Run_Time and then not In_Finalization_Root (T)) or else Is_Controlled (T) ! or else Has_Some_Controlled_Component (T) or else (Is_Concurrent_Type (T) ! and then Present (Corresponding_Record_Type (T)) ! and then Controlled_Type (Corresponding_Record_Type (T))); end Controlled_Type; -------------------------- *************** package body Exp_Ch7 is *** 2040,2046 **** Make_Exception_Handler (Loc, Exception_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( ! Make_Raise_Program_Error (Loc)))); end if; Proc_Name := Make_Defining_Identifier (Loc, Deep_Name_Of (Prim)); --- 2120,2127 ---- Make_Exception_Handler (Loc, Exception_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( ! Make_Raise_Program_Error (Loc, ! Reason => PE_Finalize_Raised_Exception)))); end if; Proc_Name := Make_Defining_Identifier (Loc, Deep_Name_Of (Prim)); diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch7.ads gcc-3.3/gcc/ada/exp_ch7.ads *** gcc-3.2.3/gcc/ada/exp_ch7.ads 2002-05-04 03:27:53.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch7.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** package Exp_Ch7 is *** 52,57 **** --- 51,60 ---- -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize -- that take care of finalization management at run-time. + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); + -- Build one controlling procedure when a late body overrides one of + -- the controlling operations. + function Controller_Component (Typ : Entity_Id) return Entity_Id; -- Returns the entity of the component whose name is 'Name_uController' diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch8.adb gcc-3.3/gcc/ada/exp_ch8.adb *** gcc-3.2.3/gcc/ada/exp_ch8.adb 2002-05-04 03:27:53.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch8.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch8.ads gcc-3.3/gcc/ada/exp_ch8.ads *** gcc-3.2.3/gcc/ada/exp_ch8.ads 2002-05-04 03:27:53.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch8.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch9.adb gcc-3.3/gcc/ada/exp_ch9.adb *** gcc-3.2.3/gcc/ada/exp_ch9.adb 2002-05-04 03:27:53.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch9.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Exp_Ch9 is *** 99,108 **** -- of the System.Address pointer passed to entry barrier functions -- and entry body procedures. - function Array_Type (E : Entity_Id; Trec : Node_Id) return Entity_Id; - -- Find the array type associated with an entry family in the - -- associated record for the task type. - function Build_Accept_Body (Astat : Node_Id) return Node_Id; -- Transform accept statement into a block with added exception handler. -- Used both for simple accept statements and for accept alternatives in --- 98,103 ---- *************** package body Exp_Ch9 is *** 592,622 **** end Add_Private_Declarations; - ---------------- - -- Array_Type -- - ---------------- - - function Array_Type (E : Entity_Id; Trec : Node_Id) return Entity_Id is - Arr : Entity_Id := First_Component (Trec); - - begin - while Present (Arr) loop - exit when Ekind (Arr) = E_Component - and then Is_Array_Type (Etype (Arr)) - and then Chars (Arr) = Chars (E); - - Next_Component (Arr); - end loop; - - -- This used to return Arr itself, but this caused problems - -- when used in expanding a protected type, possibly because - -- the record of which it is a component is not frozen yet. - -- I am going to try the type instead. This may pose visibility - -- problems. ??? - - return Etype (Arr); - end Array_Type; - ----------------------- -- Build_Accept_Body -- ----------------------- --- 587,592 ---- *************** package body Exp_Ch9 is *** 3283,3289 **** Update_Prival_Subtypes (B_F); Set_Privals (Spec_Decl, N, Loc); ! Set_Discriminals (Spec_Decl, N, Loc); Set_Scope (Func, Scope (Prot)); else Analyze (Cond); --- 3253,3259 ---- Update_Prival_Subtypes (B_F); Set_Privals (Spec_Decl, N, Loc); ! Set_Discriminals (Spec_Decl); Set_Scope (Func, Scope (Prot)); else Analyze (Cond); *************** package body Exp_Ch9 is *** 4408,4414 **** if Present (Next_Op) then Set_Privals (Dec, Next_Op, Loc); ! Set_Discriminals (Dec, Next_Op, Loc); end if; end Expand_N_Entry_Body; --- 4378,4384 ---- if Present (Next_Op) then Set_Privals (Dec, Next_Op, Loc); ! Set_Discriminals (Dec); end if; end Expand_N_Entry_Body; *************** package body Exp_Ch9 is *** 5793,5799 **** Condition => Make_Op_Eq (Loc, Left_Opnd => New_Reference_To (Xnam, Loc), Right_Opnd => ! New_Reference_To (RTE (RE_No_Rendezvous), Loc)))); return Stats; end Accept_Or_Raise; --- 5763,5770 ---- Condition => Make_Op_Eq (Loc, Left_Opnd => New_Reference_To (Xnam, Loc), Right_Opnd => ! New_Reference_To (RTE (RE_No_Rendezvous), Loc)), ! Reason => PE_All_Guards_Closed)); return Stats; end Accept_Or_Raise; *************** package body Exp_Ch9 is *** 6756,6761 **** --- 6727,6743 ---- New_N : Node_Id; begin + -- Do not attempt expansion if in no run time mode + + if No_Run_Time + and then not Restricted_Profile + then + Disallow_In_No_Run_Time_Mode (N); + return; + end if; + + -- Here we start the expansion by generating discriminal declarations + Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc); -- Add a call to Abort_Undefer at the very beginning of the task *************** package body Exp_Ch9 is *** 6922,6948 **** Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); Tasknm : constant Name_Id := Chars (Tasktyp); Taskdef : constant Node_Id := Task_Definition (N); - Proc_Spec : Node_Id; Rec_Decl : Node_Id; Rec_Ent : Entity_Id; Cdecls : List_Id; - Elab_Decl : Node_Id; Size_Decl : Node_Id; Body_Decl : Node_Id; begin ! if Present (Corresponding_Record_Type (Tasktyp)) then return; ! else ! Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); ! Rec_Ent := Defining_Identifier (Rec_Decl); ! Cdecls := Component_Items ! (Component_List (Type_Definition (Rec_Decl))); end if; Qualify_Entity_Names (N); -- First create the elaboration variable --- 6904,6940 ---- Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); Tasknm : constant Name_Id := Chars (Tasktyp); Taskdef : constant Node_Id := Task_Definition (N); + Proc_Spec : Node_Id; Rec_Decl : Node_Id; Rec_Ent : Entity_Id; Cdecls : List_Id; Elab_Decl : Node_Id; Size_Decl : Node_Id; Body_Decl : Node_Id; begin ! -- Do not attempt expansion if in no run time mode ! ! if No_Run_Time ! and then not Restricted_Profile ! then ! Disallow_In_No_Run_Time_Mode (N); return; ! -- If already expanded, nothing to do ! ! elsif Present (Corresponding_Record_Type (Tasktyp)) then ! return; end if; + -- Here we will do the expansion + + Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); + Rec_Ent := Defining_Identifier (Rec_Decl); + Cdecls := Component_Items (Component_List + (Type_Definition (Rec_Decl))); + Qualify_Entity_Names (N); -- First create the elaboration variable *************** package body Exp_Ch9 is *** 6994,7000 **** -- This is done last, since the corresponding record initialization -- procedure will reference the previously created entities. ! -- Fill in the component declarations. First the _Task_Id field: Append_To (Cdecls, Make_Component_Declaration (Loc, --- 6986,6992 ---- -- This is done last, since the corresponding record initialization -- procedure will reference the previously created entities. ! -- Fill in the component declarations. First the _Task_Id field. Append_To (Cdecls, Make_Component_Declaration (Loc, *************** package body Exp_Ch9 is *** 7116,7122 **** -- Complete the expansion of access types to the current task -- type, if any were declared. ! Expand_Previous_Access_Type (N, Tasktyp); end Expand_N_Task_Type_Declaration; ------------------------------- --- 7108,7114 ---- -- Complete the expansion of access types to the current task -- type, if any were declared. ! Expand_Previous_Access_Type (Tasktyp); end Expand_N_Task_Type_Declaration; ------------------------------- *************** package body Exp_Ch9 is *** 7462,7468 **** Op := First_Protected_Operation (Declarations (N)); if Present (Op) then ! Set_Discriminals (Parent (Spec_Id), Op, Sloc (N)); Set_Privals (Parent (Spec_Id), Op, Sloc (N)); end if; end if; --- 7454,7460 ---- Op := First_Protected_Operation (Declarations (N)); if Present (Op) then ! Set_Discriminals (Parent (Spec_Id)); Set_Privals (Parent (Spec_Id), Op, Sloc (N)); end if; end if; *************** package body Exp_Ch9 is *** 8268,8278 **** -- Set_Discriminals -- ---------------------- ! procedure Set_Discriminals ! (Dec : Node_Id; ! Op : Node_Id; ! Loc : Source_Ptr) ! is D : Entity_Id; Pdef : Entity_Id; D_Minal : Entity_Id; --- 8260,8266 ---- -- Set_Discriminals -- ---------------------- ! procedure Set_Discriminals (Dec : Node_Id) is D : Entity_Id; Pdef : Entity_Id; D_Minal : Entity_Id; *************** package body Exp_Ch9 is *** 8497,8502 **** --- 8485,8505 ---- Update_Array_Bounds (Etype (Defining_Identifier (N))); return OK; + -- For array components of discriminated records, use the + -- base type directly, because it may depend indirectly + -- on the discriminants of the protected type. Cleaner would + -- be a systematic mechanism to compute actual subtypes of + -- private components ??? + + elsif Nkind (N) in N_Has_Etype + and then Present (Etype (N)) + and then Is_Array_Type (Etype (N)) + and then Nkind (N) = N_Selected_Component + and then Has_Discriminants (Etype (Prefix (N))) + then + Set_Etype (N, Base_Type (Etype (N))); + return OK; + else if Nkind (N) in N_Has_Etype and then Present (Etype (N)) diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_ch9.ads gcc-3.3/gcc/ada/exp_ch9.ads *** gcc-3.2.3/gcc/ada/exp_ch9.ads 2002-05-04 03:27:54.000000000 +0000 --- gcc-3.3/gcc/ada/exp_ch9.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** package Exp_Ch9 is *** 289,298 **** -- Given a protected operation node (a subprogram or entry body), -- find the following node in the declarations list. ! procedure Set_Discriminals ! (Dec : Node_Id; ! Op : Node_Id; ! Loc : Source_Ptr); -- Replace discriminals in a protected type for use by the -- next protected operation on the type. Each operation needs a -- new set of discirminals, since it needs a unique renaming of --- 288,294 ---- -- Given a protected operation node (a subprogram or entry body), -- find the following node in the declarations list. ! procedure Set_Discriminals (Dec : Node_Id); -- Replace discriminals in a protected type for use by the -- next protected operation on the type. Each operation needs a -- new set of discirminals, since it needs a unique renaming of diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_code.adb gcc-3.3/gcc/ada/exp_code.adb *** gcc-3.2.3/gcc/ada/exp_code.adb 2002-05-04 03:27:55.000000000 +0000 --- gcc-3.3/gcc/ada/exp_code.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_code.ads gcc-3.3/gcc/ada/exp_code.ads *** gcc-3.2.3/gcc/ada/exp_code.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_code.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_dbug.adb gcc-3.3/gcc/ada/exp_dbug.adb *** gcc-3.2.3/gcc/ada/exp_dbug.adb 2002-05-04 03:27:56.000000000 +0000 --- gcc-3.3/gcc/ada/exp_dbug.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- 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,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- -- *************** with Opt; use Opt; *** 41,47 **** with Output; use Output; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; ! with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; --- 40,46 ---- with Output; use Output; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; ! with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; *************** package body Exp_Dbug is *** 139,144 **** --- 138,156 ---- -- building this name to realize efficiently that b needs further -- qualification. + -------------------- + -- Homonym_Suffix -- + -------------------- + + -- The string defined here (and its associated length) is used to + -- gather the homonym string that will be appended to Name_Buffer + -- when the name is complete. Strip_Suffixes appends to this string + -- as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix + -- appends the string to the end of Name_Buffer. + + Homonym_Numbers : String (1 .. 256); + Homonym_Len : Natural := 0; + ---------------------- -- Local Procedures -- ---------------------- *************** package body Exp_Dbug is *** 150,155 **** --- 162,171 ---- -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of -- the normalized numerator and denominator of the given real value. + procedure Append_Homonym_Number (E : Entity_Id); + -- If the entity E has homonyms in the same scope, then make an entry + -- in the Homonym_Numbers array, bumping Homonym_Count accordingly. + function Bounds_Match_Size (E : Entity_Id) return Boolean; -- Determine whether the bounds of E match the size of the type. This is -- used to determine whether encoding is required for a discrete type. *************** package body Exp_Dbug is *** 171,176 **** --- 187,195 ---- -- sequence in the string S (defined as two underscores -- which are preceded and followed by a non-underscore) + procedure Output_Homonym_Numbers_Suffix; + -- If homonym numbers are stored, then output them into Name_Buffer. + procedure Prepend_String_To_Buffer (S : String); -- Prepend given string to the contents of the string buffer, updating -- the value in Name_Len (i.e. string is added at start of buffer). *************** package body Exp_Dbug is *** 185,196 **** -- If not already done, replaces the Chars field of the given entity -- with the appropriate fully qualified name. ! procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean); -- Given an qualified entity name in Name_Buffer, remove any plain X or -- X{nb} qualification suffix. The contents of Name_Buffer is not changed -- but Name_Len may be adjusted on return to remove the suffix. If a ! -- suffix is found and stripped, then Suffix_Found is set to True. If ! -- no suffix is found, then Suffix_Found is not modified. ------------------------ -- Add_Real_To_Buffer -- --- 204,218 ---- -- If not already done, replaces the Chars field of the given entity -- with the appropriate fully qualified name. ! procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean); -- Given an qualified entity name in Name_Buffer, remove any plain X or -- X{nb} qualification suffix. The contents of Name_Buffer is not changed -- but Name_Len may be adjusted on return to remove the suffix. If a ! -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to ! -- True. If no suffix is found, then BNPE_Suffix_Found is not modified. ! -- This routine also searches for a homonym suffix, and if one is found ! -- it is also stripped, and the entries are added to the global homonym ! -- list (Homonym_Numbers) so that they can later be put back. ------------------------ -- Add_Real_To_Buffer -- *************** package body Exp_Dbug is *** 218,223 **** --- 240,296 ---- end if; end Add_Uint_To_Buffer; + --------------------------- + -- Append_Homonym_Number -- + --------------------------- + + procedure Append_Homonym_Number (E : Entity_Id) is + + procedure Add_Nat_To_H (Nr : Nat); + -- Little procedure to append Nr to Homonym_Numbers + + ------------------ + -- Add_Nat_To_H -- + ------------------ + + procedure Add_Nat_To_H (Nr : Nat) is + begin + if Nr >= 10 then + Add_Nat_To_H (Nr / 10); + end if; + + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := + Character'Val (Nr mod 10 + Character'Pos ('0')); + end Add_Nat_To_H; + + -- Start of processing for Append_Homonym_Number + + begin + if Has_Homonym (E) then + declare + H : Entity_Id := Homonym (E); + Nr : Nat := 1; + + begin + while Present (H) loop + if (Scope (H) = Scope (E)) then + Nr := Nr + 1; + end if; + + H := Homonym (H); + end loop; + + if Homonym_Len > 0 then + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := '_'; + end if; + + Add_Nat_To_H (Nr); + end; + end if; + end Append_Homonym_Number; + ----------------------- -- Bounds_Match_Size -- ----------------------- *************** package body Exp_Dbug is *** 827,841 **** Name_Buffer (Name_Len + 1) := ASCII.NUL; end Get_Encoded_Name; - ------------------- - -- Get_Entity_Id -- - ------------------- - - function Get_Entity_Id (External_Name : String) return Entity_Id is - begin - return Empty; - end Get_Entity_Id; - ----------------------- -- Get_External_Name -- ----------------------- --- 900,905 ---- *************** package body Exp_Dbug is *** 867,875 **** then Get_Qualified_Name_And_Append (Scope (Entity)); Add_Str_To_Name_Buffer ("__"); end if; - Get_Name_String_And_Append (Chars (Entity)); end Get_Qualified_Name_And_Append; -- Start of processing for Get_External_Name --- 931,943 ---- then Get_Qualified_Name_And_Append (Scope (Entity)); Add_Str_To_Name_Buffer ("__"); + Get_Name_String_And_Append (Chars (Entity)); + Append_Homonym_Number (Entity); + + else + Get_Name_String_And_Append (Chars (Entity)); end if; end Get_Qualified_Name_And_Append; -- Start of processing for Get_External_Name *************** package body Exp_Dbug is *** 934,965 **** end if; Get_Qualified_Name_And_Append (E); - - if Has_Homonym (E) then - declare - H : Entity_Id := Homonym (E); - Nr : Nat := 1; - - begin - while Present (H) loop - if (Scope (H) = Scope (E)) then - Nr := Nr + 1; - end if; - - H := Homonym (H); - end loop; - - if Nr > 1 then - if No_Dollar_In_Label then - Add_Str_To_Name_Buffer ("__"); - else - Add_Char_To_Name_Buffer ('$'); - end if; - - Add_Nat_To_Name_Buffer (Nr); - end if; - end; - end if; end if; Name_Buffer (Name_Len + 1) := ASCII.Nul; --- 1002,1007 ---- *************** package body Exp_Dbug is *** 1103,1108 **** --- 1145,1190 ---- return Name_Find; end Make_Packed_Array_Type_Name; + ----------------------------------- + -- Output_Homonym_Numbers_Suffix -- + ----------------------------------- + + procedure Output_Homonym_Numbers_Suffix is + J : Natural; + + begin + if Homonym_Len > 0 then + + -- Check for all 1's, in which case we do not output + + J := 1; + loop + exit when Homonym_Numbers (J) /= '1'; + + -- If we reached end of string we do not output + + if J = Homonym_Len then + Homonym_Len := 0; + return; + end if; + + exit when Homonym_Numbers (J + 1) /= '_'; + J := J + 2; + end loop; + + -- If we exit the loop then suffix must be output + + if No_Dollar_In_Label then + Add_Str_To_Name_Buffer ("__"); + else + Add_Char_To_Name_Buffer ('$'); + end if; + + Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len)); + Homonym_Len := 0; + end if; + end Output_Homonym_Numbers_Suffix; + ------------------------------ -- Prepend_String_To_Buffer -- ------------------------------ *************** package body Exp_Dbug is *** 1240,1251 **** Discard : Boolean := False; begin -- If this we are qualifying entities local to a generic -- instance, use the name of the original instantiation, -- not that of the anonymous subprogram in the wrapper -- package, so that gdb doesn't have to know about these. ! if Is_Generic_Instance (E) and then Is_Subprogram (E) and then not Comes_From_Source (E) and then not Is_Compilation_Unit (Scope (E)) --- 1322,1338 ---- Discard : Boolean := False; begin + -- Ignore empty entry (can happen in error cases) + + if No (E) then + return; + -- If this we are qualifying entities local to a generic -- instance, use the name of the original instantiation, -- not that of the anonymous subprogram in the wrapper -- package, so that gdb doesn't have to know about these. ! elsif Is_Generic_Instance (E) and then Is_Subprogram (E) and then not Comes_From_Source (E) and then not Is_Compilation_Unit (Scope (E)) *************** package body Exp_Dbug is *** 1258,1264 **** if Has_Fully_Qualified_Name (E) then Get_Name_String (Chars (E)); ! Strip_BNPE_Suffix (Discard); Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Full_Qualify_Len := Name_Len; Set_Has_Fully_Qualified_Name (Ent); --- 1345,1351 ---- if Has_Fully_Qualified_Name (E) then Get_Name_String (Chars (E)); ! Strip_Suffixes (Discard); Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Full_Qualify_Len := Name_Len; Set_Has_Fully_Qualified_Name (Ent); *************** package body Exp_Dbug is *** 1285,1290 **** --- 1372,1378 ---- (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) := Name_Buffer (1 .. Name_Len); Full_Qualify_Len := Full_Qualify_Len + Name_Len; + Append_Homonym_Number (E); end if; if Is_BNPE (E) then *************** package body Exp_Dbug is *** 1367,1373 **** if Has_Qualified_Name (E) then Get_Name_String_And_Append (Chars (E)); ! Strip_BNPE_Suffix (BNPE_Suffix_Needed); -- If the top level name we are adding is itself fully -- qualified, then that means that the name that we are --- 1455,1461 ---- if Has_Qualified_Name (E) then Get_Name_String_And_Append (Chars (E)); ! Strip_Suffixes (BNPE_Suffix_Needed); -- If the top level name we are adding is itself fully -- qualified, then that means that the name that we are *************** package body Exp_Dbug is *** 1395,1400 **** --- 1483,1490 ---- if Is_BNPE (E) then BNPE_Suffix_Needed := True; end if; + + Append_Homonym_Number (E); end if; end Set_Entity_Name; *************** package body Exp_Dbug is *** 1409,1414 **** --- 1499,1505 ---- elsif Ekind (Ent) = E_Enumeration_Literal and then Present (Debug_Renaming_Link (Ent)) then + Name_Len := 0; Set_Entity_Name (Debug_Renaming_Link (Ent)); Get_Name_String (Chars (Ent)); Prepend_String_To_Buffer *************** package body Exp_Dbug is *** 1436,1441 **** --- 1527,1534 ---- -- Fall through with a fully qualified name in Name_Buffer/Name_Len + Output_Homonym_Numbers_Suffix; + -- Add body-nested package suffix if required if BNPE_Suffix_Needed *************** package body Exp_Dbug is *** 1474,1723 **** Name_Qualify_Units.Append (N); end Qualify_Entity_Names; - -------------------------------- - -- Save_Unitname_And_Use_List -- - -------------------------------- - - procedure Save_Unitname_And_Use_List - (Main_Unit_Node : Node_Id; - Main_Kind : Node_Kind) - is - INITIAL_NAME_LENGTH : constant := 1024; - - Item : Node_Id; - Pack_Name : Node_Id; - - Unit_Spec : Node_Id := 0; - Unit_Body : Node_Id := 0; - - Main_Name : String_Id; - -- Fully qualified name of Main Unit - - Unit_Name : String_Id; - -- Name of unit specified in a Use clause - - Spec_Unit_Index : Source_File_Index; - Spec_File_Name : File_Name_Type := No_File; - - Body_Unit_Index : Source_File_Index; - Body_File_Name : File_Name_Type := No_File; - - type String_Ptr is access all String; - - Spec_File_Name_Str : String_Ptr; - Body_File_Name_Str : String_Ptr; - - type Label is record - Label_Name : String_Ptr; - Name_Length : Integer; - Pos : Integer; - end record; - - Spec_Label : Label; - Body_Label : Label; - - procedure Initialize (L : out Label); - -- Initialize label - - procedure Append (L : in out Label; Ch : Character); - -- Append character to label - - procedure Append (L : in out Label; Str : String); - -- Append string to label - - procedure Append_Name (L : in out Label; Unit_Name : String_Id); - -- Append name to label - - function Sufficient_Space - (L : Label; - Unit_Name : String_Id) - return Boolean; - -- Does sufficient space exist to append another name? - - procedure Append (L : in out Label; Str : String) is - begin - L.Label_Name (L.Pos + 1 .. L.Pos + Str'Length) := Str; - L.Pos := L.Pos + Str'Length; - end Append; - - procedure Append (L : in out Label; Ch : Character) is - begin - L.Pos := L.Pos + 1; - L.Label_Name (L.Pos) := Ch; - end Append; - - procedure Append_Name (L : in out Label; Unit_Name : String_Id) is - Char : Char_Code; - Upper_Offset : constant := Character'Pos ('a') - Character'Pos ('A'); - - begin - for J in 1 .. String_Length (Unit_Name) loop - Char := Get_String_Char (Unit_Name, J); - - if Character'Val (Char) = '.' then - Append (L, "__"); - elsif Character'Val (Char) in 'A' .. 'Z' then - Append (L, Character'Val (Char + Upper_Offset)); - elsif Char /= 0 then - Append (L, Character'Val (Char)); - end if; - end loop; - end Append_Name; - - procedure Initialize (L : out Label) is - begin - L.Name_Length := INITIAL_NAME_LENGTH; - L.Pos := 0; - L.Label_Name := new String (1 .. L.Name_Length); - end Initialize; - - function Sufficient_Space - (L : Label; - Unit_Name : String_Id) - return Boolean - is - Len : Integer := Integer (String_Length (Unit_Name)) + 1; - - begin - for J in 1 .. String_Length (Unit_Name) loop - if Character'Val (Get_String_Char (Unit_Name, J)) = '.' then - Len := Len + 1; - end if; - end loop; - - return L.Pos + Len < L.Name_Length; - end Sufficient_Space; - - -- Start of processing for Save_Unitname_And_Use_List - - begin - Initialize (Spec_Label); - Initialize (Body_Label); - - case Main_Kind is - when N_Package_Declaration => - Main_Name := Full_Qualified_Name - (Defining_Unit_Name (Specification (Unit (Main_Unit_Node)))); - Unit_Spec := Main_Unit_Node; - Append (Spec_Label, "_LPS__"); - Append (Body_Label, "_LPB__"); - - when N_Package_Body => - Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node)); - Unit_Body := Main_Unit_Node; - Main_Name := Full_Qualified_Name (Unit_Spec); - Append (Spec_Label, "_LPS__"); - Append (Body_Label, "_LPB__"); - - when N_Subprogram_Body => - Unit_Body := Main_Unit_Node; - - if Present (Corresponding_Spec (Unit (Main_Unit_Node))) then - Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node)); - Main_Name := Full_Qualified_Name - (Corresponding_Spec (Unit (Main_Unit_Node))); - else - Main_Name := Full_Qualified_Name - (Defining_Unit_Name (Specification (Unit (Main_Unit_Node)))); - end if; - - Append (Spec_Label, "_LSS__"); - Append (Body_Label, "_LSB__"); - - when others => - return; - end case; - - Append_Name (Spec_Label, Main_Name); - Append_Name (Body_Label, Main_Name); - - -- If we have a body, process it first - - if Present (Unit_Body) then - - Item := First (Context_Items (Unit_Body)); - - while Present (Item) loop - if Nkind (Item) = N_Use_Package_Clause then - Pack_Name := First (Names (Item)); - while Present (Pack_Name) loop - Unit_Name := Full_Qualified_Name (Entity (Pack_Name)); - - if Sufficient_Space (Body_Label, Unit_Name) then - Append (Body_Label, '$'); - Append_Name (Body_Label, Unit_Name); - end if; - - Pack_Name := Next (Pack_Name); - end loop; - end if; - - Item := Next (Item); - end loop; - end if; - - while Present (Unit_Spec) and then - Nkind (Unit_Spec) /= N_Compilation_Unit - loop - Unit_Spec := Parent (Unit_Spec); - end loop; - - if Present (Unit_Spec) then - - Item := First (Context_Items (Unit_Spec)); - - while Present (Item) loop - if Nkind (Item) = N_Use_Package_Clause then - Pack_Name := First (Names (Item)); - while Present (Pack_Name) loop - Unit_Name := Full_Qualified_Name (Entity (Pack_Name)); - - if Sufficient_Space (Spec_Label, Unit_Name) then - Append (Spec_Label, '$'); - Append_Name (Spec_Label, Unit_Name); - end if; - - if Sufficient_Space (Body_Label, Unit_Name) then - Append (Body_Label, '$'); - Append_Name (Body_Label, Unit_Name); - end if; - - Pack_Name := Next (Pack_Name); - end loop; - end if; - - Item := Next (Item); - end loop; - end if; - - if Present (Unit_Spec) then - Append (Spec_Label, Character'Val (0)); - Spec_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Spec)); - Spec_File_Name := Full_File_Name (Spec_Unit_Index); - Get_Name_String (Spec_File_Name); - Spec_File_Name_Str := new String (1 .. Name_Len + 1); - Spec_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); - Spec_File_Name_Str (Name_Len + 1) := Character'Val (0); - Spec_Filename := Spec_File_Name_Str (1)'Unrestricted_Access; - Spec_Context_List := - Spec_Label.Label_Name.all (1)'Unrestricted_Access; - end if; - - if Present (Unit_Body) then - Append (Body_Label, Character'Val (0)); - Body_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Body)); - Body_File_Name := Full_File_Name (Body_Unit_Index); - Get_Name_String (Body_File_Name); - Body_File_Name_Str := new String (1 .. Name_Len + 1); - Body_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); - Body_File_Name_Str (Name_Len + 1) := Character'Val (0); - Body_Filename := Body_File_Name_Str (1)'Unrestricted_Access; - Body_Context_List := - Body_Label.Label_Name.all (1)'Unrestricted_Access; - end if; - - end Save_Unitname_And_Use_List; - --------- -- SEq -- --------- --- 1567,1572 ---- *************** package body Exp_Dbug is *** 1737,1757 **** (Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length)); end SHash; ! ----------------------- ! -- Strip_BNPE_Suffix -- ! ----------------------- - procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean) is begin for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = 'X' then Name_Len := J - 1; ! Suffix_Found := True; exit; end if; exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n'; end loop; ! end Strip_BNPE_Suffix; end Exp_Dbug; --- 1586,1661 ---- (Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length)); end SHash; ! -------------------- ! -- Strip_Suffixes -- ! -------------------- ! ! procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is ! SL : Natural; begin + -- Search for and strip BNPE suffix + for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = 'X' then Name_Len := J - 1; ! BNPE_Suffix_Found := True; exit; end if; exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n'; end loop; ! ! -- Search for and strip homonym numbers suffix ! ! -- Case of __ used for homonym numbers suffix ! ! if No_Dollar_In_Label then ! for J in reverse 2 .. Name_Len - 2 loop ! if Name_Buffer (J) = '_' ! and then Name_Buffer (J + 1) = '_' ! then ! if Name_Buffer (J + 2) in '0' .. '9' then ! if Homonym_Len > 0 then ! Homonym_Len := Homonym_Len + 1; ! Homonym_Numbers (Homonym_Len) := '-'; ! end if; ! ! SL := Name_Len - (J + 1); ! ! Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) := ! Name_Buffer (J + 2 .. Name_Len); ! Name_Len := J - 1; ! Homonym_Len := Homonym_Len + SL; ! end if; ! ! exit; ! end if; ! end loop; ! ! -- Case of $ used for homonym numbers suffix ! ! else ! for J in reverse 2 .. Name_Len - 1 loop ! if Name_Buffer (J) = '$' then ! if Name_Buffer (J + 1) in '0' .. '9' then ! if Homonym_Len > 0 then ! Homonym_Len := Homonym_Len + 1; ! Homonym_Numbers (Homonym_Len) := '-'; ! end if; ! ! SL := Name_Len - J; ! ! Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) := ! Name_Buffer (J + 1 .. Name_Len); ! Name_Len := J - 1; ! Homonym_Len := Homonym_Len + SL; ! end if; ! ! exit; ! end if; ! end loop; ! end if; ! end Strip_Suffixes; end Exp_Dbug; diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_dbug.ads gcc-3.3/gcc/ada/exp_dbug.ads *** gcc-3.2.3/gcc/ada/exp_dbug.ads 2002-05-04 03:27:56.000000000 +0000 --- gcc-3.3/gcc/ada/exp_dbug.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,13 ---- -- -- -- 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- -- *************** *** 30,36 **** -- debugger. In accordance with the Dwarf 2.2 specification, certain -- type names are encoded to provide information to the debugger. - with Sinfo; use Sinfo; with Types; use Types; with Uintp; use Uintp; with Get_Targ; use Get_Targ; --- 29,34 ---- *************** package Exp_Dbug is *** 63,71 **** -- case of nested procedures.) In addition, we also consider all types -- to be global entities, even if they are defined within a procedure. ! -- The reason for full treating all type names as global entities is ! -- that a number of our type encodings work by having related type ! -- names, and we need the full qualification to keep this unique. -- For global entities, the encoded name includes all components of the -- fully expanded name (but omitting Standard at the start). For example, --- 61,69 ---- -- case of nested procedures.) In addition, we also consider all types -- to be global entities, even if they are defined within a procedure. ! -- The reason for treating all type names as global entities is that ! -- a number of our type encodings work by having related type names, ! -- and we need the full qualification to keep this unique. -- For global entities, the encoded name includes all components of the -- fully expanded name (but omitting Standard at the start). For example, *************** package Exp_Dbug is *** 95,104 **** -- The separating dots are translated into double underscores. - -- Note: there is one exception, which is that on IRIX, for workshop - -- back compatibility, dots are retained as dots. In the rest of this - -- document we assume the double underscore encoding. - ----------------------------- -- Handling of Overloading -- ----------------------------- --- 93,98 ---- *************** package Exp_Dbug is *** 107,167 **** -- subprograms, since overloading can legitimately result in a -- case of two entities with exactly the same fully qualified names. -- To distinguish between entries in a set of overloaded subprograms, ! -- the encoded names are serialized by adding one of the two suffixes: -- $n (dollar sign) -- __nn (two underscores) ! -- where nn is a serial number (1 for the first overloaded function, ! -- 2 for the second, etc.). The former suffix is used when a dollar ! -- sign is a valid symbol on the target machine and the latter is ! -- used when it is not. No suffix need appear on the encoding of ! -- the first overloading of a subprogram. -- These names are prefixed by the normal full qualification. So -- for example, the third instance of the subprogram qrs in package ! -- yz would have one of the two names: -- yz__qrs$3 - -- yz__qrs__3 ! -- The serial number always appears at the end as shown, even in the ! -- case of subprograms nested inside overloaded subprograms, and only ! -- when the named subprogram is overloaded. For example, consider ! -- the following situation: -- package body Yz is ! -- procedure Qrs is -- Encoded name is yz__qrs ! -- procedure Tuv is ... end; -- Encoded name is yz__qrs__tuv -- begin ... end Qrs; ! -- procedure Qrs (X: Integer) is -- Encoded name is yz__qrs__2 ! -- procedure Tuv is ... end; -- Encoded name is yz__qrs__tuv ! -- -- (not yz__qrs__2__tuv). ! -- procedure Tuv (X: INTEGER) -- Encoded name is yz__qrs__tuv__2 -- begin ... end Tuv; ! -- procedure Tuv (X: INTEGER) -- Encoded name is yz__qrs__tuv__3 -- begin ... end Tuv; -- begin ... end Qrs; -- end Yz; - -- This example also serves to illustrate, a case in which the - -- debugging data are currently ambiguous. The two parameterless - -- versions of Yz.Qrs.Tuv have the same encoded names in the - -- debugging data. However, the actual external symbols (which - -- linkers use to resolve references) will be modified with an - -- an additional suffix so that they do not clash. Thus, there will - -- be cases in which the name of a function shown in the debugging - -- data differs from that function's "official" external name, and - -- in which several different functions have exactly the same name - -- as far as the debugger is concerned. We don't consider this too - -- much of a problem, since the only way the user has of referring - -- to these functions by name is, in fact, Yz.Qrs.Tuv, so that the - -- reference is inherently ambiguous from the user's perspective, - -- regardless of internal encodings (in these cases, the debugger - -- can provide a menu of options to allow the user to disambiguate). - -------------------- -- Operator Names -- -------------------- --- 101,159 ---- -- subprograms, since overloading can legitimately result in a -- case of two entities with exactly the same fully qualified names. -- To distinguish between entries in a set of overloaded subprograms, ! -- the encoded names are serialized by adding one of the suffixes: -- $n (dollar sign) -- __nn (two underscores) ! -- where nn is a serial number (2 for the second overloaded function, ! -- 2 for the third, etc.). We use $ if this symbol is allowed, and ! -- double underscore if it is not. In the remaining examples in this ! -- section, we use a $ sign, but the $ is replaced by __ throughout ! -- these examples if $ sign is not available. A suffix of $1 is ! -- always omitted (i.e. no suffix implies the first instance). -- These names are prefixed by the normal full qualification. So -- for example, the third instance of the subprogram qrs in package ! -- yz would have the name: -- yz__qrs$3 ! -- A more subtle case arises with entities declared within overloaded ! -- subprograms. If we have two overloaded subprograms, and both declare ! -- an entity xyz, then the fully expanded name of the two xyz's is the ! -- same. To distinguish these, we add the same __n suffix at the end of ! -- the inner entity names. ! ! -- In more complex cases, we can have multiple levels of overloading, ! -- and we must make sure to distinguish which final declarative region ! -- we are talking about. For this purpose, we use a more complex suffix ! -- which has the form: ! ! -- $nn_nn_nn ... ! ! -- where the nn values are the homonym numbers as needed for any of ! -- the qualifying entities, separated by a single underscore. If all ! -- the nn values are 1, the suffix is omitted, Otherwise the suffix ! -- is present (including any values of 1). The following example ! -- shows how this suffixing works. -- package body Yz is ! -- procedure Qrs is -- Name is yz__qrs ! -- procedure Tuv is ... end; -- Name is yz__qrs__tuv -- begin ... end Qrs; ! -- procedure Qrs (X: Int) is -- Name is yz__qrs$2 ! -- procedure Tuv is ... end; -- Name is yz__qrs__tuv$2_1 ! -- procedure Tuv (X: Int) is -- Name is yz__qrs__tuv$2_2 -- begin ... end Tuv; ! -- procedure Tuv (X: Float) is -- Name is yz__qrs__tuv$2_3 ! -- type m is new float; -- Name is yz__qrs__tuv__m$2_3 -- begin ... end Tuv; -- begin ... end Qrs; -- end Yz; -------------------- -- Operator Names -- -------------------- *************** package Exp_Dbug is *** 217,223 **** -- interpretation 1: entity c in child package a.b -- interpretation 2: entity c in nested package b in body of a ! -- It is perfectly valid in both cases for both interpretations to -- be valid within a single program. This is a bit of a surprise since -- certainly in Ada 83, full qualification was sufficient, but not in -- Ada 95. The result is that the above scheme can result in duplicate --- 209,215 ---- -- interpretation 1: entity c in child package a.b -- interpretation 2: entity c in nested package b in body of a ! -- It is perfectly legal in both cases for both interpretations to -- be valid within a single program. This is a bit of a surprise since -- certainly in Ada 83, full qualification was sufficient, but not in -- Ada 95. The result is that the above scheme can result in duplicate *************** package Exp_Dbug is *** 367,376 **** -- from outside of the object, and a non-locking one that is used for -- calls from other operations on the same object. The locking operation -- simply acquires the lock, and then calls the non-locking version. ! -- The names of all of these have a prefix constructed from the name ! -- of the name of the type, the string "PT", and a suffix which is P ! -- or N, depending on whether this is the protected or non-locking ! -- version of the operation. -- Given the declaration: --- 359,367 ---- -- from outside of the object, and a non-locking one that is used for -- calls from other operations on the same object. The locking operation -- simply acquires the lock, and then calls the non-locking version. ! -- The names of all of these have a prefix constructed from the name of ! -- the type, the string "PT", and a suffix which is P or N, depending on ! -- whether this is the protected/non-locking version of the operation. -- Given the declaration: *************** package Exp_Dbug is *** 410,416 **** -- or "X_" if the next entity is a subunit) -- - the name of the entity -- - the string "$" (or "__" if target does not allow "$"), followed ! -- by homonym number, if the entity is an overloaded subprogram procedure Get_External_Name_With_Suffix (Entity : Entity_Id; --- 401,408 ---- -- or "X_" if the next entity is a subunit) -- - the name of the entity -- - the string "$" (or "__" if target does not allow "$"), followed ! -- by homonym suffix, if the entity is an overloaded subprogram ! -- or is defined within an overloaded subprogram. procedure Get_External_Name_With_Suffix (Entity : Entity_Id; *************** package Exp_Dbug is *** 424,436 **** -- or "X_" if the next entity is a subunit) -- - the name of the entity -- - the string "$" (or "__" if target does not allow "$"), followed ! -- by homonym number, if the entity is an overloaded subprogram -- - the string "___" followed by Suffix - function Get_Entity_Id (External_Name : String) return Entity_Id; - -- Find entity in current compilation unit, which has the given - -- External_Name. - ---------------------------- -- Debug Name Compression -- ---------------------------- --- 416,425 ---- -- or "X_" if the next entity is a subunit) -- - the name of the entity -- - the string "$" (or "__" if target does not allow "$"), followed ! -- by homonym suffix, if the entity is an overloaded subprogram ! -- or is defined within an overloaded subprogram. -- - the string "___" followed by Suffix ---------------------------- -- Debug Name Compression -- ---------------------------- *************** package Exp_Dbug is *** 653,658 **** --- 642,663 ---- -- or static values, with the encoding first for the lower bound, -- then for the upper bound, as previously described. + ------------------- + -- Modular Types -- + ------------------- + + -- A type declared + + -- type x is mod N; + + -- Is encoded as a subrange of an unsigned base type with lower bound + -- 0 and upper bound N. That is, there is no name encoding. We use + -- the standard encodings provided by the debugging format. Thus + -- we give these types a non-standard interpretation: the standard + -- interpretation of our encoding would not, in general, imply that + -- arithmetic on type x was to be performed modulo N (especially not + -- when N is not a power of 2). + ------------------ -- Biased Types -- ------------------ *************** package Exp_Dbug is *** 760,765 **** --- 765,785 ---- -- that contains the variants is replaced by a normal C union. -- In this case, the positions are all zero. + -- Discriminants appear before any variable-length fields that depend + -- on them, with one exception. In some cases, a discriminant + -- governing the choice of a variant clause may appear in the list + -- of fields of an XVE type after the entry for the variant clause + -- itself (this can happen in the presence of a representation clause + -- for the record type in the source program). However, when this + -- happens, the discriminant's position may be determined by first + -- applying the rules described in this section, ignoring the variant + -- clause. As a result, discriminants can always be located + -- independently of the variable-length fields that depend on them. + + -- The size of the ___XVE or ___XVU record or union is set to the + -- alignment (in bytes) of the original object so that the debugger + -- can calculate the size of the original type. + -- As an example of this encoding, consider the declarations: -- type Q is array (1 .. V1) of Float; -- alignment 4 *************** package Exp_Dbug is *** 805,819 **** -- but this may not be detected in this case by the conversion -- routines. - -- All discriminants always appear before any variable-length - -- fields that depend on them. So they can be located independent - -- of the variable-length field, using the standard procedure for - -- computing positions described above. - - -- The size of the ___XVE or ___XVU record or union is set to the - -- alignment (in bytes) of the original object so that the debugger - -- can calculate the size of the original type. - -- 3) Our conventions do not cover all XVE-encoded records in which -- some, but not all, fields have representation clauses. Such -- records may, therefore, be displayed incorrectly by debuggers. --- 825,830 ---- *************** package Exp_Dbug is *** 1350,1428 **** -- the second enumeration literal would be named QU43 and the -- value assigned to it would be 1. - ------------------- - -- Modular Types -- - ------------------- - - -- A type declared - - -- type x is mod N; - - -- Is encoded as a subrange of an unsigned base type with lower bound - -- 0 and upper bound N. That is, there is no name encoding; we only use - -- the standard encodings provided by the debugging format. Thus, - -- we give these types a non-standard interpretation: the standard - -- interpretation of our encoding would not, in general, imply that - -- arithmetic on type x was to be performed modulo N (especially not - -- when N is not a power of 2). - - --------------------- - -- Context Clauses -- - --------------------- - - -- The SGI Workshop debugger requires a very peculiar and nonstandard - -- symbol name containing $ signs to be generated that records the - -- use clauses that are used in a unit. GDB does not use this name, - -- since it takes a different philsophy of universal use visibility, - -- with manual resolution of any ambiguities. - - -- The routines and data in this section are used to prepare this - -- specialized name, whose exact contents are described below. Gigi - -- will output this encoded name only in the SGI case (indeed, not - -- only is it useless on other targets, but hazardous, given the use - -- of the non-standard character $ rejected by many assemblers.) - - -- "Use" clauses are encoded as follows: - - -- _LSS__ prefix for clauses in a subprogram spec - -- _LSB__ prefix for clauses in a subprogram body - -- _LPS__ prefix for clauses in a package spec - -- _LPB__ prefix for clauses in a package body - - -- Following the prefix is the fully qualified filename, followed by - -- '$' separated names of fully qualified units in the "use" clause. - -- If a unit appears in both the spec and the body "use" clause, it - -- will appear once in the _L[SP]S__ encoding and twice in the _L[SP]B__ - -- encoding. The encoding appears as a global symbol in the object file. - - ------------------------------------------------------------------------ - -- Subprograms and Declarations for Handling Context Clause Encodings -- - ------------------------------------------------------------------------ - - procedure Save_Unitname_And_Use_List - (Main_Unit_Node : Node_Id; - Main_Kind : Node_Kind); - -- Creates a string containing the current compilation unit name - -- and a dollar sign delimited list of packages named in a Use_Package - -- clause for the compilation unit. Needed for the SGI debugger. The - -- procedure is called unconditionally to set the variables declared - -- below, then gigi decides whether or not to use the values. - - -- The following variables are used for communication between the front - -- end and the debugging output routines in Gigi. - - type Char_Ptr is access all Character; - pragma Convention (C, Char_Ptr); - -- Character pointers accessed from C - - Spec_Context_List, Body_Context_List : Char_Ptr; - -- List of use package clauses for spec and body, respectively, as - -- built by the call to Save_Unitname_And_Use_List. Used by gigi if - -- these strings are to be output. - - Spec_Filename, Body_Filename : Char_Ptr; - -- Filenames for the spec and body, respectively, as built by the - -- call to Save_Unitname_And_Use_List. Used by gigi if these strings - -- are to be output. - end Exp_Dbug; --- 1361,1364 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_disp.adb gcc-3.3/gcc/ada/exp_disp.adb *** gcc-3.2.3/gcc/ada/exp_disp.adb 2002-05-04 03:27:56.000000000 +0000 --- gcc-3.3/gcc/ada/exp_disp.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_disp.ads gcc-3.3/gcc/ada/exp_disp.ads *** gcc-3.2.3/gcc/ada/exp_disp.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_disp.ads 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- ! -- 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,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- -- *************** package Exp_Disp is *** 54,60 **** TSD_Entry_Size, TSD_Prologue_Size); - function Fill_DT_Entry (Loc : Source_Ptr; Prim : Entity_Id) --- 53,58 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_dist.adb gcc-3.3/gcc/ada/exp_dist.adb *** gcc-3.2.3/gcc/ada/exp_dist.adb 2002-05-04 03:27:57.000000000 +0000 --- gcc-3.3/gcc/ada/exp_dist.adb 2002-10-23 07:33:23.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Exp_Dist is *** 58,64 **** -- form: -- type Stub is tagged record -- [...declaration similar to s-parint.ads RACW_Stub_Type...] ! -- end Stub; -- is built. This type has two properties: -- -- 1) Since it has the same structure than RACW_Stub_Type, it can be --- 57,63 ---- -- form: -- type Stub is tagged record -- [...declaration similar to s-parint.ads RACW_Stub_Type...] ! -- end record; -- is built. This type has two properties: -- -- 1) Since it has the same structure than RACW_Stub_Type, it can be *************** package body Exp_Dist is *** 2635,2641 **** Append_To (Decls, Make_Raise_Constraint_Error (Loc, Condition => ! Make_Op_Not (Loc, Right_Opnd => Condition))); end Insert_Partition_Check; -- Start of processing for Build_Subprogram_Calling_Stubs --- 2634,2641 ---- Append_To (Decls, Make_Raise_Constraint_Error (Loc, Condition => ! Make_Op_Not (Loc, Right_Opnd => Condition), ! Reason => CE_Partition_Check_Failed)); end Insert_Partition_Check; -- Start of processing for Build_Subprogram_Calling_Stubs diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_dist.ads gcc-3.3/gcc/ada/exp_dist.ads *** gcc-3.2.3/gcc/ada/exp_dist.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_dist.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/expect.c gcc-3.3/gcc/ada/expect.c *** gcc-3.2.3/gcc/ada/expect.c 2001-10-02 14:08:33.000000000 +0000 --- gcc-3.3/gcc/ada/expect.c 2002-03-14 10:59:16.000000000 +0000 *************** *** 6,14 **** * * * C Implementation File * * * - * $Revision: 1.1 $ * * ! * Copyright (C) 2001 Ada Core Technologies, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * --- 6,13 ---- * * * C Implementation File * * * * * ! * Copyright (C) 2001-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- * *************** __gnat_expect_fork () *** 74,84 **** } void ! __gnat_expect_portable_execvp (cmd, argv) char *cmd; char *argv[]; { ! (void) spawnve (_P_NOWAIT, cmd, argv, NULL); } int --- 73,84 ---- } void ! __gnat_expect_portable_execvp (pid, cmd, argv) ! int *pid; char *cmd; char *argv[]; { ! *pid = (int) spawnve (_P_NOWAIT, cmd, argv, NULL); } int *************** __gnat_expect_poll (fd, num_fd, timeout, *** 108,122 **** is_set[i] = 0; for (i = 0; i < num_fd; i++) ! handles[i] = (HANDLE) _get_osfhandle (fd [i]); ! num = timeout / 10; while (1) { for (i = 0; i < num_fd; i++) { ! if (!PeekNamedPipe (handles [i], NULL, 0, NULL, &avail, NULL)) return -1; if (avail > 0) --- 108,122 ---- is_set[i] = 0; for (i = 0; i < num_fd; i++) ! handles[i] = (HANDLE) _get_osfhandle (fd[i]); ! num = timeout / 50; while (1) { for (i = 0; i < num_fd; i++) { ! if (!PeekNamedPipe (handles[i], NULL, 0, NULL, &avail, NULL)) return -1; if (avail > 0) *************** __gnat_expect_poll (fd, num_fd, timeout, *** 129,139 **** if (timeout >= 0 && num == 0) return 0; ! Sleep (10); num--; } } #elif defined (unix) #include --- 129,258 ---- if (timeout >= 0 && num == 0) return 0; ! Sleep (50); num--; } } + #elif defined (VMS) + #include + #include + #include + #include + #include + #include + #include + #include + #include + + int + __gnat_pipe (fd) + int *fd; + { + return pipe (fd); + } + + int + __gnat_expect_fork () + { + return -1; + } + + void + __gnat_expect_portable_execvp (pid, cmd, argv) + int *pid; + char *cmd; + char *argv[]; + { + *pid = (int) getpid(); + /* Since cmd is fully qualified, it is incorrect to to call execvp */ + execv (cmd, argv); + } + + int + __gnat_expect_poll (fd, num_fd, timeout, is_set) + int *fd; + int num_fd; + int timeout; + int *is_set; + { + int i, num, ready = 0; + unsigned int status; + int mbxchans [num_fd]; + struct dsc$descriptor_s mbxname; + struct io_status_block { + short int condition; + short int count; + int dev; + } iosb; + char buf [256]; + + for (i = 0; i < num_fd; i++) + is_set[i] = 0; + + for (i = 0; i < num_fd; i++) + { + + /* Get name of the mailbox used in the pipe */ + getname (fd [i], buf); + + /* Assign a channel to the mailbox */ + if (strlen (buf) > 0) + { + mbxname.dsc$w_length = strlen (buf); + mbxname.dsc$b_dtype = DSC$K_DTYPE_T; + mbxname.dsc$b_class = DSC$K_CLASS_S; + mbxname.dsc$a_pointer = buf; + + status = SYS$ASSIGN (&mbxname, &mbxchans[i], 0, 0, 0); + } + } + + num = timeout / 100; + + while (1) + { + for (i = 0; i < num_fd; i++) + { + if (mbxchans[i] > 0) + { + + /* Peek in the mailbox to see if there's data */ + status = SYS$QIOW + (0, mbxchans[i], IO$_SENSEMODE|IO$M_READERCHECK, + &iosb, 0, 0, 0, 0, 0, 0, 0, 0); + + if (iosb.count > 0) + { + is_set[i] = 1; + ready = 1; + goto deassign; + } + } + } + + if (timeout >= 0 && num == 0) + { + ready = 0; + goto deassign; + } + + usleep (100000); + num--; + } + + deassign: + + /* Deassign channels assigned above */ + for (i = 0; i < num_fd; i++) + { + if (mbxchans[i] > 0) + status = SYS$DASSGN (mbxchans[i]); + } + + return ready; + } + #elif defined (unix) #include *************** __gnat_expect_fork () *** 165,174 **** } void ! __gnat_expect_portable_execvp (cmd, argv) char *cmd; char *argv[]; { execvp (cmd, argv); } --- 284,295 ---- } void ! __gnat_expect_portable_execvp (pid, cmd, argv) ! int *pid; char *cmd; char *argv[]; { + *pid = (int) getpid(); execvp (cmd, argv); } *************** __gnat_expect_poll (fd, num_fd, timeout, *** 189,197 **** for (i = 0; i < num_fd; i++) { ! FD_SET (fd [i], &rset); ! if (fd [i] > max_fd) ! max_fd = fd [i]; } tv.tv_sec = timeout / 1000; --- 310,318 ---- for (i = 0; i < num_fd; i++) { ! FD_SET (fd[i], &rset); ! if (fd[i] > max_fd) ! max_fd = fd[i]; } tv.tv_sec = timeout / 1000; *************** __gnat_expect_poll (fd, num_fd, timeout, *** 201,207 **** if (ready > 0) for (i = 0; i < num_fd; i++) ! is_set [i] = (FD_ISSET (fd [i], &rset) ? 1 : 0); return ready; } --- 322,328 ---- if (ready > 0) for (i = 0; i < num_fd; i++) ! is_set[i] = (FD_ISSET (fd[i], &rset) ? 1 : 0); return ready; } *************** __gnat_expect_fork () *** 222,231 **** } void ! __gnat_expect_portable_execvp (cmd, argv) char *cmd; char *argv[]; { } int --- 343,354 ---- } void ! __gnat_expect_portable_execvp (pid, cmd, argv) ! int *pid; char *cmd; char *argv[]; { + *pid = 0; } int diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_fixd.adb gcc-3.3/gcc/ada/exp_fixd.adb *** gcc-3.2.3/gcc/ada/exp_fixd.adb 2002-05-04 03:27:58.000000000 +0000 --- gcc-3.3/gcc/ada/exp_fixd.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Exp_Fixd is *** 1960,1965 **** --- 1959,1971 ---- Right : constant Node_Id := Right_Opnd (N); begin + -- Suppress expansion of a fixed-by-fixed division if the + -- operation is supported directly by the target. + + if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then + return; + end if; + if Etype (Left) = Universal_Real then Do_Divide_Universal_Fixed (N); *************** package body Exp_Fixd is *** 2100,2105 **** --- 2106,2118 ---- end Rewrite_Non_Static_Universal; begin + -- Suppress expansion of a fixed-by-fixed multiplication if the + -- operation is supported directly by the target. + + if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then + return; + end if; + if Etype (Left) = Universal_Real then if Nkind (Left) = N_Real_Literal then Do_Multiply_Fixed_Universal (N, Right, Left); diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_fixd.ads gcc-3.3/gcc/ada/exp_fixd.ads *** gcc-3.2.3/gcc/ada/exp_fixd.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_fixd.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_imgv.adb gcc-3.3/gcc/ada/exp_imgv.adb *** gcc-3.2.3/gcc/ada/exp_imgv.adb 2002-05-04 03:27:59.000000000 +0000 --- gcc-3.3/gcc/ada/exp_imgv.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.12.1 $ -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_imgv.ads gcc-3.3/gcc/ada/exp_imgv.ads *** gcc-3.2.3/gcc/ada/exp_imgv.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_imgv.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_intr.adb gcc-3.3/gcc/ada/exp_intr.adb *** gcc-3.2.3/gcc/ada/exp_intr.adb 2002-05-04 03:27:59.000000000 +0000 --- gcc-3.3/gcc/ada/exp_intr.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Exp_Intr is *** 82,92 **** -- Expand a call to an instantiation of Unchecked_Convertion into a node -- N_Unchecked_Type_Conversion. ! procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id); -- Expand a call to an instantiation of Unchecked_Deallocation into a node -- N_Free_Statement and appropriate context. ! procedure Expand_Source_Info (N : Node_Id; E : Entity_Id; Nam : Name_Id); -- Rewrite the node by the appropriate string or positive constant. -- Nam can be one of the following: -- Name_File - expand string that is the name of source file --- 81,91 ---- -- Expand a call to an instantiation of Unchecked_Convertion into a node -- N_Unchecked_Type_Conversion. ! procedure Expand_Unc_Deallocation (N : Node_Id); -- Expand a call to an instantiation of Unchecked_Deallocation into a node -- N_Free_Statement and appropriate context. ! procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); -- Rewrite the node by the appropriate string or positive constant. -- Nam can be one of the following: -- Name_File - expand string that is the name of source file *************** package body Exp_Intr is *** 267,280 **** Expand_Unc_Conversion (N, E); elsif Nam = Name_Unchecked_Deallocation then ! Expand_Unc_Deallocation (N, E); elsif Nam = Name_File or else Nam = Name_Line or else Nam = Name_Source_Location or else Nam = Name_Enclosing_Entity then ! Expand_Source_Info (N, E, Nam); else -- Only other possibility is a renaming, in which case we expand --- 266,279 ---- Expand_Unc_Conversion (N, E); elsif Nam = Name_Unchecked_Deallocation then ! Expand_Unc_Deallocation (N); elsif Nam = Name_File or else Nam = Name_Line or else Nam = Name_Source_Location or else Nam = Name_Enclosing_Entity then ! Expand_Source_Info (N, Nam); else -- Only other possibility is a renaming, in which case we expand *************** package body Exp_Intr is *** 389,395 **** -- Expand_Source_Info -- ------------------------ ! procedure Expand_Source_Info (N : Node_Id; E : Entity_Id; Nam : Name_Id) is Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; --- 388,394 ---- -- Expand_Source_Info -- ------------------------ ! procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; *************** package body Exp_Intr is *** 515,521 **** -- task itself is freed if it is terminated, ditto for a simple protected -- object, with a call to Finalize_Protection ! procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Arg : constant Node_Id := First_Actual (N); Typ : constant Entity_Id := Etype (Arg); --- 514,520 ---- -- task itself is freed if it is terminated, ditto for a simple protected -- object, with a call to Finalize_Protection ! procedure Expand_Unc_Deallocation (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Arg : constant Node_Id := First_Actual (N); Typ : constant Entity_Id := Etype (Arg); diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_intr.ads gcc-3.3/gcc/ada/exp_intr.ads *** gcc-3.2.3/gcc/ada/exp_intr.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_intr.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_pakd.adb gcc-3.3/gcc/ada/exp_pakd.adb *** gcc-3.2.3/gcc/ada/exp_pakd.adb 2002-05-04 03:27:59.000000000 +0000 --- gcc-3.3/gcc/ada/exp_pakd.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Exp_Pakd is *** 591,597 **** Right_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))); -- For larger integer types, subtract first, then convert to --- 590,596 ---- Right_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))); -- For larger integer types, subtract first, then convert to *************** package body Exp_Pakd is *** 606,612 **** Left_Opnd => Newsub, Right_Opnd => Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))); end if; --- 605,611 ---- Left_Opnd => Newsub, Right_Opnd => Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))); end if; *************** package body Exp_Pakd is *** 625,642 **** Make_Op_Subtract (Loc, Left_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_Pos, ! Expressions => New_List (Newsub))), Right_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_Pos, ! Expressions => New_List ( Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))))); end if; --- 624,641 ---- Make_Op_Subtract (Loc, Left_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_Pos, ! Expressions => New_List (Newsub))), Right_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_Pos, ! Expressions => New_List ( Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))))); end if; *************** package body Exp_Pakd is *** 761,767 **** end if; Set_Is_Itype (PAT, True); ! Set_Is_Packed_Array_Type (PAT, True); Analyze (Decl, Suppress => All_Checks); if Pushed_Scope then --- 760,766 ---- end if; Set_Is_Itype (PAT, True); ! Set_Packed_Array_Type (Typ, PAT); Analyze (Decl, Suppress => All_Checks); if Pushed_Scope then *************** package body Exp_Pakd is *** 780,789 **** -- Set remaining fields of packed array type ! Init_Alignment (PAT); ! Set_Parent (PAT, Empty); ! Set_Packed_Array_Type (Typ, PAT); Set_Associated_Node_For_Itype (PAT, Typ); -- We definitely do not want to delay freezing for packed array -- types. This is of particular importance for the itypes that --- 779,789 ---- -- Set remaining fields of packed array type ! Init_Alignment (PAT); ! Set_Parent (PAT, Empty); Set_Associated_Node_For_Itype (PAT, Typ); + Set_Is_Packed_Array_Type (PAT, True); + Set_Original_Array_Type (PAT, Typ); -- We definitely do not want to delay freezing for packed array -- types. This is of particular importance for the itypes that *************** package body Exp_Pakd is *** 801,814 **** procedure Set_PB_Type is begin -- If the user has specified an explicit alignment for the ! -- component, take it into account. if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0 or else Component_Alignment (Typ) = Calign_Storage_Unit then PB_Type := RTE (RE_Packed_Bytes1); ! elsif Csize mod 4 /= 0 then PB_Type := RTE (RE_Packed_Bytes2); else --- 801,817 ---- procedure Set_PB_Type is begin -- If the user has specified an explicit alignment for the ! -- type or component, take it into account. if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0 + or else Alignment (Typ) = 1 or else Component_Alignment (Typ) = Calign_Storage_Unit then PB_Type := RTE (RE_Packed_Bytes1); ! elsif Csize mod 4 /= 0 ! or else Alignment (Typ) = 2 ! then PB_Type := RTE (RE_Packed_Bytes2); else *************** package body Exp_Pakd is *** 973,989 **** Type_Definition => Typedef); end; Install_PAT; return; ! -- Case of bit-packing required for unconstrained array. We simply ! -- use Packed_Bytes{1,2,4} as appropriate, and we do not need to ! -- construct a special packed array type. elsif not Is_Constrained (Typ) then Set_PB_Type; ! Set_Packed_Array_Type (Typ, PB_Type); ! Set_Is_Packed_Array_Type (Packed_Array_Type (Typ), True); return; -- Remaining code is for the case of bit-packing for constrained array --- 976,1003 ---- Type_Definition => Typedef); end; + -- Set type as packed array type and install it + + Set_Is_Packed_Array_Type (PAT); Install_PAT; return; ! -- Case of bit-packing required for unconstrained array. We create ! -- a subtype that is equivalent to use Packed_Bytes{1,2,4} as needed. elsif not Is_Constrained (Typ) then + PAT := + Make_Defining_Identifier (Loc, + Chars => Make_Packed_Array_Type_Name (Typ, Csize)); + + Set_Packed_Array_Type (Typ, PAT); Set_PB_Type; ! ! Decl := ! Make_Subtype_Declaration (Loc, ! Defining_Identifier => PAT, ! Subtype_Indication => New_Occurrence_Of (PB_Type, Loc)); ! Install_PAT; return; -- Remaining code is for the case of bit-packing for constrained array *************** package body Exp_Pakd is *** 1453,1461 **** Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Set_nn, Loc), Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => Obj), Subscr, Unchecked_Convert_To (Bits_nn, Convert_To (Ctyp, Rhs))))); --- 1467,1475 ---- Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Set_nn, Loc), Parameter_Associations => New_List ( ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => Obj), Subscr, Unchecked_Convert_To (Bits_nn, Convert_To (Ctyp, Rhs))))); *************** package body Exp_Pakd is *** 1507,1519 **** Left_Opnd => Subscr, Right_Opnd => Make_Attribute_Reference (Ploc, ! Prefix => New_Occurrence_Of (Atyp, Ploc), Attribute_Name => Name_Component_Size)); elsif Nkind (Pref) = N_Selected_Component then Term := Make_Attribute_Reference (Ploc, ! Prefix => Selector_Name (Pref), Attribute_Name => Name_Bit_Position); else --- 1521,1533 ---- Left_Opnd => Subscr, Right_Opnd => Make_Attribute_Reference (Ploc, ! Prefix => New_Occurrence_Of (Atyp, Ploc), Attribute_Name => Name_Component_Size)); elsif Nkind (Pref) = N_Selected_Component then Term := Make_Attribute_Reference (Ploc, ! Prefix => Selector_Name (Pref), Attribute_Name => Name_Bit_Position); else *************** package body Exp_Pakd is *** 1541,1547 **** Left_Opnd => Unchecked_Convert_To (RTE (RE_Integer_Address), Make_Attribute_Reference (Loc, ! Prefix => Pref, Attribute_Name => Name_Address)), Right_Opnd => --- 1555,1561 ---- Left_Opnd => Unchecked_Convert_To (RTE (RE_Integer_Address), Make_Attribute_Reference (Loc, ! Prefix => Pref, Attribute_Name => Name_Address)), Right_Opnd => *************** package body Exp_Pakd is *** 1619,1625 **** Right_Opnd => Convert_To (BT, ! New_Occurrence_Of (Standard_True, Loc)))))); end; end if; --- 1633,1640 ---- Right_Opnd => Convert_To (BT, ! New_Occurrence_Of (Standard_True, Loc)))), ! Reason => CE_Range_Check_Failed)); end; end if; *************** package body Exp_Pakd is *** 1701,1709 **** Name => New_Occurrence_Of (RTE (E_Id), Loc), Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => L), Make_Op_Multiply (Loc, Left_Opnd => --- 1716,1724 ---- Name => New_Occurrence_Of (RTE (E_Id), Loc), Parameter_Associations => New_List ( ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => L), Make_Op_Multiply (Loc, Left_Opnd => *************** package body Exp_Pakd is *** 1715,1723 **** Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp))), ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => R), Make_Op_Multiply (Loc, Left_Opnd => --- 1730,1738 ---- Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp))), ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => R), Make_Op_Multiply (Loc, Left_Opnd => *************** package body Exp_Pakd is *** 1729,1735 **** Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))), ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, Prefix => New_Occurrence_Of (Result_Ent, Loc)))))); --- 1744,1750 ---- Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))), ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, Prefix => New_Occurrence_Of (Result_Ent, Loc)))))); *************** package body Exp_Pakd is *** 1841,1849 **** Make_Function_Call (Loc, Name => New_Occurrence_Of (Get_nn, Loc), Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => Obj), Subscr)))); end; end if; --- 1856,1864 ---- Make_Function_Call (Loc, Name => New_Occurrence_Of (Get_nn, Loc), Parameter_Associations => New_List ( ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => Obj), Subscr)))); end; end if; *************** package body Exp_Pakd is *** 1885,1891 **** Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, ! Prefix => New_Occurrence_Of (Ltyp, Loc)), Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp))); --- 1900,1906 ---- Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, ! Prefix => New_Occurrence_Of (Ltyp, Loc)), Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp))); *************** package body Exp_Pakd is *** 1894,1900 **** Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, ! Prefix => New_Occurrence_Of (Rtyp, Loc)), Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))); --- 1909,1915 ---- Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, ! Prefix => New_Occurrence_Of (Rtyp, Loc)), Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))); *************** package body Exp_Pakd is *** 1934,1948 **** Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc), Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => L), LLexpr, ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => R), RLexpr))); end if; --- 1949,1963 ---- Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc), Parameter_Associations => New_List ( ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => L), LLexpr, ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => R), RLexpr))); end if; *************** package body Exp_Pakd is *** 1995,2001 **** Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (CT, Loc), ! Attribute_Name => Name_Last)))); end; -- Now that that silliness is taken care of, get packed array type --- 2010,2017 ---- Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (CT, Loc), ! Attribute_Name => Name_Last)), ! Reason => CE_Range_Check_Failed)); end; -- Now that that silliness is taken care of, get packed array type *************** package body Exp_Pakd is *** 2052,2060 **** Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc), Parameter_Associations => New_List ( ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => Opnd), Make_Op_Multiply (Loc, Left_Opnd => --- 2068,2076 ---- Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc), Parameter_Associations => New_List ( ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, ! Prefix => Opnd), Make_Op_Multiply (Loc, Left_Opnd => *************** package body Exp_Pakd is *** 2066,2072 **** Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))), ! Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, Prefix => New_Occurrence_Of (Result_Ent, Loc)))))); --- 2082,2088 ---- Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))), ! Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, Prefix => New_Occurrence_Of (Result_Ent, Loc)))))); *************** package body Exp_Pakd is *** 2146,2158 **** -- If we have a specified alignment, see if it is sufficient, if not -- then we can't possibly be aligned enough in any case. ! elsif Is_Entity_Name (Obj) ! and then Known_Alignment (Entity (Obj)) ! then -- Alignment required is 4 if size is a multiple of 4, and -- 2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2) ! if Alignment (Entity (Obj)) < 4 - (Csiz mod 4) then return False; end if; end if; --- 2162,2172 ---- -- If we have a specified alignment, see if it is sufficient, if not -- then we can't possibly be aligned enough in any case. ! elsif Known_Alignment (Etype (Obj)) then -- Alignment required is 4 if size is a multiple of 4, and -- 2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2) ! if Alignment (Etype (Obj)) < 4 - (Csiz mod 4) then return False; end if; end if; *************** package body Exp_Pakd is *** 2345,2351 **** then Rewrite (Expr, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Expr_Typ, Loc), Attribute_Name => Name_Pos, Expressions => New_List (Relocate_Node (Expr)))); Analyze_And_Resolve (Expr, Standard_Natural); --- 2359,2365 ---- then Rewrite (Expr, Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Expr_Typ, Loc), Attribute_Name => Name_Pos, Expressions => New_List (Relocate_Node (Expr)))); Analyze_And_Resolve (Expr, Standard_Natural); diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_pakd.ads gcc-3.3/gcc/ada/exp_pakd.ads *** gcc-3.2.3/gcc/ada/exp_pakd.ads 2002-05-04 03:28:00.000000000 +0000 --- gcc-3.3/gcc/ada/exp_pakd.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_prag.adb gcc-3.3/gcc/ada/exp_prag.adb *** gcc-3.2.3/gcc/ada/exp_prag.adb 2002-05-04 03:28:00.000000000 +0000 --- gcc-3.3/gcc/ada/exp_prag.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Exp_Prag is *** 59,65 **** function Arg1 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id; - function Arg3 (N : Node_Id) return Node_Id; -- Obtain specified Pragma_Argument_Association procedure Expand_Pragma_Abort_Defer (N : Node_Id); --- 58,63 ---- *************** package body Exp_Prag is *** 69,93 **** procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); ! -------------- ! -- Arg1,2,3 -- ! -------------- function Arg1 (N : Node_Id) return Node_Id is begin return First (Pragma_Argument_Associations (N)); end Arg1; function Arg2 (N : Node_Id) return Node_Id is begin return Next (Arg1 (N)); end Arg2; - function Arg3 (N : Node_Id) return Node_Id is - begin - return Next (Arg2 (N)); - end Arg3; - --------------------- -- Expand_N_Pragma -- --------------------- --- 67,90 ---- procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); ! ---------- ! -- Arg1 -- ! ---------- function Arg1 (N : Node_Id) return Node_Id is begin return First (Pragma_Argument_Associations (N)); end Arg1; + ---------- + -- Arg2 -- + ---------- + function Arg2 (N : Node_Id) return Node_Id is begin return Next (Arg1 (N)); end Arg2; --------------------- -- Expand_N_Pragma -- --------------------- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_prag.ads gcc-3.3/gcc/ada/exp_prag.ads *** gcc-3.2.3/gcc/ada/exp_prag.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_prag.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_smem.adb gcc-3.3/gcc/ada/exp_smem.adb *** gcc-3.2.3/gcc/ada/exp_smem.adb 2002-05-04 03:28:01.000000000 +0000 --- gcc-3.3/gcc/ada/exp_smem.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_smem.ads gcc-3.3/gcc/ada/exp_smem.ads *** gcc-3.2.3/gcc/ada/exp_smem.ads 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_smem.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1998-2000, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_strm.adb gcc-3.3/gcc/ada/exp_strm.adb *** gcc-3.2.3/gcc/ada/exp_strm.adb 2002-05-04 03:28:01.000000000 +0000 --- gcc-3.3/gcc/ada/exp_strm.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package body Exp_Strm is *** 807,813 **** -- procedure is erroneous, because there are no discriminants to read. if Is_Unchecked_Union (Typ) then ! Stms := New_List (Make_Raise_Program_Error (Loc)); end if; if Is_Non_Empty_List ( --- 806,815 ---- -- procedure is erroneous, because there are no discriminants to read. if Is_Unchecked_Union (Typ) then ! Stms := ! New_List ( ! Make_Raise_Program_Error (Loc, ! Reason => PE_Unchecked_Union_Restriction)); end if; if Is_Non_Empty_List ( *************** package body Exp_Strm is *** 870,876 **** -- because there are no discriminants to write. if Is_Unchecked_Union (Typ) then ! Stms := New_List (Make_Raise_Program_Error (Loc)); end if; if Is_Non_Empty_List ( --- 872,881 ---- -- because there are no discriminants to write. if Is_Unchecked_Union (Typ) then ! Stms := ! New_List ( ! Make_Raise_Program_Error (Loc, ! Reason => PE_Unchecked_Union_Restriction)); end if; if Is_Non_Empty_List ( *************** package body Exp_Strm is *** 890,899 **** -- The function we build looks like -- function InputN (S : access RST) return Typ is ! -- C1 : constant Disc_Type_1 := Discr_Type_1'Input (S); ! -- C2 : constant Disc_Type_1 := Discr_Type_2'Input (S); -- ... ! -- Cn : constant Disc_Type_1 := Discr_Type_n'Input (S); -- V : Typ (C1, C2, .. Cn) -- begin --- 895,907 ---- -- The function we build looks like -- function InputN (S : access RST) return Typ is ! -- C1 : constant Disc_Type_1; ! -- Discr_Type_1'Read (S, C1); ! -- C2 : constant Disc_Type_2; ! -- Discr_Type_2'Read (S, C2); -- ... ! -- Cn : constant Disc_Type_n; ! -- Discr_Type_n'Read (S, Cn); -- V : Typ (C1, C2, .. Cn) -- begin *************** package body Exp_Strm is *** 934,947 **** Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Cn), ! Object_Definition => New_Occurrence_Of (Etype (Discr), Loc), ! Expression => ! Make_Attribute_Reference (Loc, ! Prefix => ! New_Occurrence_Of ! (Stream_Base_Type (Etype (Discr)), Loc), ! Attribute_Name => Name_Input, ! Expressions => New_List (Make_Identifier (Loc, Name_S))))); Append_To (Constr, Make_Identifier (Loc, Cn)); --- 942,957 ---- Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Cn), ! Object_Definition => ! New_Occurrence_Of (Etype (Discr), Loc))); ! ! Append_To (Decls, ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (Etype (Discr), Loc), ! Attribute_Name => Name_Read, ! Expressions => New_List ( ! Make_Identifier (Loc, Name_S), ! Make_Identifier (Loc, Cn)))); Append_To (Constr, Make_Identifier (Loc, Cn)); *************** package body Exp_Strm is *** 1161,1167 **** if Present (VP) then if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then ! return New_List (Make_Raise_Program_Error (Sloc (VP))); end if; V := First_Non_Pragma (Variants (VP)); --- 1171,1179 ---- if Present (VP) then if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then ! return New_List ( ! Make_Raise_Program_Error (Sloc (VP), ! Reason => PE_Unchecked_Union_Restriction)); end if; V := First_Non_Pragma (Variants (VP)); diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_strm.ads gcc-3.3/gcc/ada/exp_strm.ads *** gcc-3.2.3/gcc/ada/exp_strm.ads 2002-05-04 03:28:01.000000000 +0000 --- gcc-3.3/gcc/ada/exp_strm.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_tss.adb gcc-3.3/gcc/ada/exp_tss.adb *** gcc-3.2.3/gcc/ada/exp_tss.adb 2002-05-04 03:28:01.000000000 +0000 --- gcc-3.3/gcc/ada/exp_tss.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_tss.ads gcc-3.3/gcc/ada/exp_tss.ads *** gcc-3.2.3/gcc/ada/exp_tss.ads 2002-05-04 03:28:01.000000000 +0000 --- gcc-3.3/gcc/ada/exp_tss.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_util.adb gcc-3.3/gcc/ada/exp_util.adb *** gcc-3.2.3/gcc/ada/exp_util.adb 2002-05-04 03:28:01.000000000 +0000 --- gcc-3.3/gcc/ada/exp_util.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.9.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Sem_Util; use Sem_Util; *** 50,58 **** --- 49,59 ---- with Sinfo; use Sinfo; with Stand; use Stand; with Stringt; use Stringt; + with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; + with Urealp; use Urealp; with Validsw; use Validsw; package body Exp_Util is *************** package body Exp_Util is *** 98,104 **** function Build_Task_Record_Image (Loc : Source_Ptr; Id_Ref : Node_Id; - A_Type : Entity_Id; Dyn : Boolean := False) return Node_Id; -- Build function to generate the image string for a task that is a --- 99,104 ---- *************** package body Exp_Util is *** 633,639 **** T_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Selector_Name (Id_Ref)), 'I')); ! Fun := Build_Task_Record_Image (Loc, Id_Ref, A_Type, Is_Dyn); elsif Nkind (Id_Ref) = N_Indexed_Component then T_Id := --- 633,639 ---- T_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Selector_Name (Id_Ref)), 'I')); ! Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn); elsif Nkind (Id_Ref) = N_Indexed_Component then T_Id := *************** package body Exp_Util is *** 786,792 **** function Build_Task_Record_Image (Loc : Source_Ptr; Id_Ref : Node_Id; - A_Type : Entity_Id; Dyn : Boolean := False) return Node_Id is --- 786,791 ---- *************** package body Exp_Util is *** 970,975 **** --- 969,1010 ---- return New_Copy_Tree (Exp); end Duplicate_Subexpr; + --------------------------------- + -- Duplicate_Subexpr_No_Checks -- + --------------------------------- + + function Duplicate_Subexpr_No_Checks + (Exp : Node_Id; + Name_Req : Boolean := False) + return Node_Id + is + New_Exp : Node_Id; + + begin + Remove_Side_Effects (Exp, Name_Req); + New_Exp := New_Copy_Tree (Exp); + Remove_Checks (New_Exp); + return New_Exp; + end Duplicate_Subexpr_No_Checks; + + ----------------------------------- + -- Duplicate_Subexpr_Move_Checks -- + ----------------------------------- + + function Duplicate_Subexpr_Move_Checks + (Exp : Node_Id; + Name_Req : Boolean := False) + return Node_Id + is + New_Exp : Node_Id; + + begin + Remove_Side_Effects (Exp, Name_Req); + New_Exp := New_Copy_Tree (Exp); + Remove_Checks (Exp); + return New_Exp; + end Duplicate_Subexpr_Move_Checks; + -------------------- -- Ensure_Defined -- -------------------- *************** package body Exp_Util is *** 1657,1663 **** if Nkind (Parent (P)) = N_Aggregate and then Present (Aggregate_Bounds (Parent (P))) and then Nkind (First (Choices (P))) = N_Others_Choice - and then Nkind (First (Ins_Actions)) /= N_Freeze_Entity then if No (Loop_Actions (P)) then Set_Loop_Actions (P, Ins_Actions); --- 1692,1697 ---- *************** package body Exp_Util is *** 2093,2104 **** Remove_Handler_Entries (N); Remove_Warning_Messages (N); ! -- Recurse into block statements to process declarations/statements ! if Nkind (N) = N_Block_Statement then Kill_Dead_Code (Declarations (N)); Kill_Dead_Code (Statements (Handled_Statement_Sequence (N))); -- Recurse into composite statement to kill individual statements, -- in particular instantiations. --- 2127,2146 ---- Remove_Handler_Entries (N); Remove_Warning_Messages (N); ! -- Recurse into block statements and bodies to process declarations ! -- and statements ! if Nkind (N) = N_Block_Statement ! or else Nkind (N) = N_Subprogram_Body ! or else Nkind (N) = N_Package_Body ! then Kill_Dead_Code (Declarations (N)); Kill_Dead_Code (Statements (Handled_Statement_Sequence (N))); + if Nkind (N) = N_Subprogram_Body then + Set_Is_Eliminated (Defining_Entity (N)); + end if; + -- Recurse into composite statement to kill individual statements, -- in particular instantiations. *************** package body Exp_Util is *** 2168,2173 **** --- 2210,2298 ---- end if; end Known_Non_Negative; + -------------------------- + -- Target_Has_Fixed_Ops -- + -------------------------- + + Integer_Sized_Small : Ureal; + -- Set to 2.0 ** -(Integer'Size - 1) the first time that this + -- function is called (we don't want to compute it more than once!) + + Long_Integer_Sized_Small : Ureal; + -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this + -- functoin is called (we don't want to compute it more than once) + + First_Time_For_THFO : Boolean := True; + -- Set to False after first call (if Fractional_Fixed_Ops_On_Target) + + function Target_Has_Fixed_Ops + (Left_Typ : Entity_Id; + Right_Typ : Entity_Id; + Result_Typ : Entity_Id) + return Boolean + is + function Is_Fractional_Type (Typ : Entity_Id) return Boolean; + -- Return True if the given type is a fixed-point type with a small + -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have + -- an absolute value less than 1.0. This is currently limited + -- to fixed-point types that map to Integer or Long_Integer. + + ------------------------ + -- Is_Fractional_Type -- + ------------------------ + + function Is_Fractional_Type (Typ : Entity_Id) return Boolean is + begin + if Esize (Typ) = Standard_Integer_Size then + return Small_Value (Typ) = Integer_Sized_Small; + + elsif Esize (Typ) = Standard_Long_Integer_Size then + return Small_Value (Typ) = Long_Integer_Sized_Small; + + else + return False; + end if; + end Is_Fractional_Type; + + -- Start of processing for Target_Has_Fixed_Ops + + begin + -- Return False if Fractional_Fixed_Ops_On_Target is false + + if not Fractional_Fixed_Ops_On_Target then + return False; + end if; + + -- Here the target has Fractional_Fixed_Ops, if first time, compute + -- standard constants used by Is_Fractional_Type. + + if First_Time_For_THFO then + First_Time_For_THFO := False; + + Integer_Sized_Small := + UR_From_Components + (Num => Uint_1, + Den => UI_From_Int (Standard_Integer_Size - 1), + Rbase => 2); + + Long_Integer_Sized_Small := + UR_From_Components + (Num => Uint_1, + Den => UI_From_Int (Standard_Long_Integer_Size - 1), + Rbase => 2); + end if; + + -- Return True if target supports fixed-by-fixed multiply/divide + -- for fractional fixed-point types (see Is_Fractional_Type) and + -- the operand and result types are equivalent fractional types. + + return Is_Fractional_Type (Base_Type (Left_Typ)) + and then Is_Fractional_Type (Base_Type (Right_Typ)) + and then Is_Fractional_Type (Base_Type (Result_Typ)) + and then Esize (Left_Typ) = Esize (Right_Typ) + and then Esize (Left_Typ) = Esize (Result_Typ); + end Target_Has_Fixed_Ops; + ----------------------------- -- Make_CW_Equivalent_Type -- ----------------------------- *************** package body Exp_Util is *** 2221,2227 **** Make_Op_Subtract (Loc, Left_Opnd => Make_Attribute_Reference (Loc, ! Prefix => OK_Convert_To (T, Duplicate_Subexpr (E)), Attribute_Name => Name_Size), Right_Opnd => Make_Attribute_Reference (Loc, --- 2346,2353 ---- Make_Op_Subtract (Loc, Left_Opnd => Make_Attribute_Reference (Loc, ! Prefix => ! OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), Attribute_Name => Name_Size), Right_Opnd => Make_Attribute_Reference (Loc, *************** package body Exp_Util is *** 2363,2369 **** Utyp := Underlying_Type (Unc_Typ); Full_Subtyp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); ! Full_Exp := Unchecked_Convert_To (Utyp, Duplicate_Subexpr (E)); Set_Parent (Full_Exp, Parent (E)); Priv_Subtyp := --- 2489,2497 ---- Utyp := Underlying_Type (Unc_Typ); Full_Subtyp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); ! Full_Exp := ! Unchecked_Convert_To ! (Utyp, Duplicate_Subexpr_No_Checks (E)); Set_Parent (Full_Exp, Parent (E)); Priv_Subtyp := *************** package body Exp_Util is *** 2401,2413 **** Make_Range (Loc, Low_Bound => Make_Attribute_Reference (Loc, ! Prefix => Duplicate_Subexpr (E), Attribute_Name => Name_First, Expressions => New_List ( Make_Integer_Literal (Loc, J))), High_Bound => Make_Attribute_Reference (Loc, ! Prefix => Duplicate_Subexpr (E), Attribute_Name => Name_Last, Expressions => New_List ( Make_Integer_Literal (Loc, J))))); --- 2529,2542 ---- Make_Range (Loc, Low_Bound => Make_Attribute_Reference (Loc, ! Prefix => Duplicate_Subexpr_No_Checks (E), Attribute_Name => Name_First, Expressions => New_List ( Make_Integer_Literal (Loc, J))), + High_Bound => Make_Attribute_Reference (Loc, ! Prefix => Duplicate_Subexpr_No_Checks (E), Attribute_Name => Name_Last, Expressions => New_List ( Make_Integer_Literal (Loc, J))))); *************** package body Exp_Util is *** 2441,2447 **** Append_To (List_Constr, Make_Selected_Component (Loc, ! Prefix => Duplicate_Subexpr (E), Selector_Name => New_Reference_To (D, Loc))); Next_Discriminant (D); --- 2570,2576 ---- Append_To (List_Constr, Make_Selected_Component (Loc, ! Prefix => Duplicate_Subexpr_No_Checks (E), Selector_Name => New_Reference_To (D, Loc))); Next_Discriminant (D); diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_util.ads gcc-3.3/gcc/ada/exp_util.ads *** gcc-3.2.3/gcc/ada/exp_util.ads 2002-05-04 03:28:01.000000000 +0000 --- gcc-3.3/gcc/ada/exp_util.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** package Exp_Util is *** 244,249 **** --- 243,274 ---- -- copy after it is attached to the tree. The Name_Req flag is set to -- ensure that the result is suitable for use in a context requiring a -- name (e.g. the prefix of an attribute reference). + -- + -- Note that if there are any run time checks in Exp, these same checks + -- will be duplicated in the returned duplicated expression. The two + -- following functions allow this behavior to be modified. + + function Duplicate_Subexpr_No_Checks + (Exp : Node_Id; + Name_Req : Boolean := False) + return Node_Id; + -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks + -- is called on the result, so that the duplicated expression does not + -- include checks. This is appropriate for use when Exp, the original + -- expression is unconditionally elaborated before the duplicated + -- expression, so that there is no need to repeat any checks. + + function Duplicate_Subexpr_Move_Checks + (Exp : Node_Id; + Name_Req : Boolean := False) + return Node_Id; + -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks + -- is called on Exp after the duplication is complete, so that the + -- original expression does not include checks. In this case the result + -- returned (the duplicated expression) will retain the original checks. + -- This is appropriate for use when the duplicated expression is sure + -- to be elaborated before the original expression Exp, so that there + -- is no need to repeat the checks. procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id); -- This procedure ensures that type referenced by Typ is defined. For the *************** package Exp_Util is *** 407,412 **** --- 432,447 ---- -- in the binder. We do that so that we can detect cases where this is -- the only elaboration action that is required. + function Target_Has_Fixed_Ops + (Left_Typ : Entity_Id; + Right_Typ : Entity_Id; + Result_Typ : Entity_Id) + return Boolean; + -- Returns True if and only if the target machine has direct support + -- for fixed-by-fixed multiplications and divisions for the given + -- operand and result types. This is called in package Exp_Fixd to + -- determine whether to expand such operations. + procedure Wrap_Cleanup_Procedure (N : Node_Id); -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer -- call at the start of the statement sequence, and an Abort_Undefer call diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_vfpt.adb gcc-3.3/gcc/ada/exp_vfpt.adb *** gcc-3.2.3/gcc/ada/exp_vfpt.adb 2002-05-07 08:22:12.000000000 +0000 --- gcc-3.3/gcc/ada/exp_vfpt.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/exp_vfpt.ads gcc-3.3/gcc/ada/exp_vfpt.ads *** gcc-3.2.3/gcc/ada/exp_vfpt.ads 2002-05-07 08:22:13.000000000 +0000 --- gcc-3.3/gcc/ada/exp_vfpt.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/fe.h gcc-3.3/gcc/ada/fe.h *** gcc-3.2.3/gcc/ada/fe.h 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fe.h 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** * * * C Header File * * * - * $Revision: 1.1.16.1 $ * * ! * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * --- 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- * *************** extern void Set_RM_Size PARAMS ((Entit *** 81,86 **** --- 80,93 ---- extern void Set_Component_Bit_Offset PARAMS ((Entity_Id, Uint)); extern void Set_Present_Expr PARAMS ((Node_Id, Uint)); + /* Test if the node N is the name of an entity (i.e. is an identifier, + expanded name, or an attribute reference that returns an entity). */ + #define Is_Entity_Name einfo__is_entity_name + extern Boolean Is_Entity_Name PARAMS ((Node_Id)); + + #define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause + extern Node_Id Get_Attribute_Definition_Clause PARAMS ((Entity_Id, char)); + /* errout: */ #define Error_Msg_N errout__error_msg_n *************** extern Boolean In_Extended_Main_Code_Uni *** 144,150 **** --- 151,162 ---- /* opt: */ #define Global_Discard_Names opt__global_discard_names + #define Exception_Mechanism opt__exception_mechanism + + typedef enum {Setjmp_Longjmp, Front_End_ZCX, GCC_ZCX} Exception_Mechanism_Type; + extern Boolean Global_Discard_Names; + extern Exception_Mechanism_Type Exception_Mechanism; /* restrict: */ *************** extern Boolean Global_Discard_Names; *** 154,165 **** extern void Check_Elaboration_Code_Allowed PARAMS ((Node_Id)); extern Boolean No_Exception_Handlers_Set PARAMS ((void)); - /* sem_ch13: */ - - #define Get_Attribute_Definition_Clause \ - sem_ch13__get_attribute_definition_clause - extern Node_Id Get_Attribute_Definition_Clause PARAMS ((Entity_Id, char)); - /* sem_eval: */ #define Compile_Time_Known_Value sem_eval__compile_time_known_value --- 166,171 ---- *************** extern void Set_Has_No_Elaboration_Code *** 194,197 **** #define Stack_Check_Probes_On_Target targparm__stack_check_probes_on_target extern Boolean Stack_Check_Probes_On_Target; - --- 200,202 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/fmap.adb gcc-3.3/gcc/ada/fmap.adb *** gcc-3.2.3/gcc/ada/fmap.adb 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fmap.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.14.1 $ -- -- -- Copyright (C) 2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** *** 26,34 **** -- -- ------------------------------------------------------------------------------ ! with Namet; use Namet; ! with Osint; use Osint; ! with Output; use Output; with Table; with Unchecked_Conversion; --- 25,35 ---- -- -- ------------------------------------------------------------------------------ ! with GNAT.OS_Lib; use GNAT.OS_Lib; ! with Namet; use Namet; ! with Opt; use Opt; ! with Osint; use Osint; ! with Output; use Output; with Table; with Unchecked_Conversion; *************** package body Fmap is *** 43,50 **** function To_Big_String_Ptr is new Unchecked_Conversion (Source_Buffer_Ptr, Big_String_Ptr); package File_Mapping is new Table.Table ( ! Table_Component_Type => File_Name_Type, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 1_000, --- 44,56 ---- function To_Big_String_Ptr is new Unchecked_Conversion (Source_Buffer_Ptr, Big_String_Ptr); + type Mapping is record + Uname : Unit_Name_Type; + Fname : File_Name_Type; + end record; + package File_Mapping is new Table.Table ( ! Table_Component_Type => Mapping, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 1_000, *************** package body Fmap is *** 53,59 **** -- Mapping table to map unit names to file names. package Path_Mapping is new Table.Table ( ! Table_Component_Type => File_Name_Type, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 1_000, --- 59,65 ---- -- Mapping table to map unit names to file names. package Path_Mapping is new Table.Table ( ! Table_Component_Type => Mapping, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 1_000, *************** package body Fmap is *** 89,94 **** --- 95,102 ---- -- Hash table to map file names to path names. Used in conjunction with -- table Path_Mapping above. + Last_In_Table : Int := 0; + --------------------- -- Add_To_File_Map -- --------------------- *************** package body Fmap is *** 101,110 **** begin File_Mapping.Increment_Last; Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last); ! File_Mapping.Table (File_Mapping.Last) := File_Name; Path_Mapping.Increment_Last; File_Hash_Table.Set (File_Name, Path_Mapping.Last); ! Path_Mapping.Table (Path_Mapping.Last) := Path_Name; end Add_To_File_Map; ---------- --- 109,120 ---- begin File_Mapping.Increment_Last; Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last); ! File_Mapping.Table (File_Mapping.Last) := ! (Uname => Unit_Name, Fname => File_Name); Path_Mapping.Increment_Last; File_Hash_Table.Set (File_Name, Path_Mapping.Last); ! Path_Mapping.Table (Path_Mapping.Last) := ! (Uname => Unit_Name, Fname => Path_Name); end Add_To_File_Map; ---------- *************** package body Fmap is *** 126,138 **** BS : Big_String_Ptr; SP : String_Ptr; ! Deb : Positive := 1; ! Fin : Natural := 0; Uname : Unit_Name_Type; Fname : Name_Id; Pname : Name_Id; procedure Empty_Tables; -- Remove all entries in case of incorrect mapping file --- 136,150 ---- BS : Big_String_Ptr; SP : String_Ptr; ! First : Positive := 1; ! Last : Natural := 0; Uname : Unit_Name_Type; Fname : Name_Id; Pname : Name_Id; + The_Mapping : Mapping; + procedure Empty_Tables; -- Remove all entries in case of incorrect mapping file *************** package body Fmap is *** 153,158 **** --- 165,171 ---- File_Hash_Table.Reset; Path_Mapping.Set_Last (0); File_Mapping.Set_Last (0); + Last_In_Table := 0; end Empty_Tables; -------------- *************** package body Fmap is *** 163,191 **** use ASCII; begin ! Deb := Fin + 1; -- If not at the end of file, skip the end of line ! while Deb < SP'Last ! and then (SP (Deb) = CR ! or else SP (Deb) = LF ! or else SP (Deb) = EOF) loop ! Deb := Deb + 1; end loop; ! -- If not at the end of line, find the end of this new line ! if Deb < SP'Last and then SP (Deb) /= EOF then ! Fin := Deb; ! while Fin < SP'Last ! and then SP (Fin + 1) /= CR ! and then SP (Fin + 1) /= LF ! and then SP (Fin + 1) /= EOF loop ! Fin := Fin + 1; end loop; end if; --- 176,204 ---- use ASCII; begin ! First := Last + 1; -- If not at the end of file, skip the end of line ! while First < SP'Last ! and then (SP (First) = CR ! or else SP (First) = LF ! or else SP (First) = EOF) loop ! First := First + 1; end loop; ! -- If not at the end of file, find the end of this new line ! if First < SP'Last and then SP (First) /= EOF then ! Last := First; ! while Last < SP'Last ! and then SP (Last + 1) /= CR ! and then SP (Last + 1) /= LF ! and then SP (Last + 1) /= EOF loop ! Last := Last + 1; end loop; end if; *************** package body Fmap is *** 197,218 **** procedure Report_Truncated is begin ! Write_Str ("warning: mapping file """); ! Write_Str (File_Name); ! Write_Line (""" is truncated"); end Report_Truncated; -- Start of procedure Initialize begin Name_Len := File_Name'Length; Name_Buffer (1 .. Name_Len) := File_Name; Read_Source_File (Name_Enter, 0, Hi, Src, Config); if Src = null then ! Write_Str ("warning: could not read mapping file """); ! Write_Str (File_Name); ! Write_Line (""""); else BS := To_Big_String_Ptr (Src); --- 210,236 ---- procedure Report_Truncated is begin ! if not Quiet_Output then ! Write_Str ("warning: mapping file """); ! Write_Str (File_Name); ! Write_Line (""" is truncated"); ! end if; end Report_Truncated; -- Start of procedure Initialize begin + Empty_Tables; Name_Len := File_Name'Length; Name_Buffer (1 .. Name_Len) := File_Name; Read_Source_File (Name_Enter, 0, Hi, Src, Config); if Src = null then ! if not Quiet_Output then ! Write_Str ("warning: could not read mapping file """); ! Write_Str (File_Name); ! Write_Line (""""); ! end if; else BS := To_Big_String_Ptr (Src); *************** package body Fmap is *** 225,238 **** -- Exit if end of file has been reached ! exit when Deb > Fin; ! pragma Assert (Fin >= Deb + 2); ! pragma Assert (SP (Fin - 1) = '%'); ! pragma Assert (SP (Fin) = 's' or else SP (Fin) = 'b'); ! Name_Len := Fin - Deb + 1; ! Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); Uname := Name_Find; -- Get the file name --- 243,256 ---- -- Exit if end of file has been reached ! exit when First > Last; ! pragma Assert (Last >= First + 2); ! pragma Assert (SP (Last - 1) = '%'); ! pragma Assert (SP (Last) = 's' or else SP (Last) = 'b'); ! Name_Len := Last - First + 1; ! Name_Buffer (1 .. Name_Len) := SP (First .. Last); Uname := Name_Find; -- Get the file name *************** package body Fmap is *** 241,254 **** -- If end of line has been reached, file is truncated ! if Deb > Fin then Report_Truncated; Empty_Tables; return; end if; ! Name_Len := Fin - Deb + 1; ! Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); Fname := Name_Find; -- Get the path name --- 259,272 ---- -- If end of line has been reached, file is truncated ! if First > Last then Report_Truncated; Empty_Tables; return; end if; ! Name_Len := Last - First + 1; ! Name_Buffer (1 .. Name_Len) := SP (First .. Last); Fname := Name_Find; -- Get the path name *************** package body Fmap is *** 257,290 **** -- If end of line has been reached, file is truncated ! if Deb > Fin then Report_Truncated; Empty_Tables; return; end if; ! Name_Len := Fin - Deb + 1; ! Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); Pname := Name_Find; -- Check for duplicate entries if Unit_Hash_Table.Get (Uname) /= No_Entry then ! Write_Str ("warning: duplicate entry """); ! Write_Str (Get_Name_String (Uname)); ! Write_Str (""" in mapping file """); ! Write_Str (File_Name); ! Write_Line (""""); Empty_Tables; return; end if; if File_Hash_Table.Get (Fname) /= No_Entry then ! Write_Str ("warning: duplicate entry """); ! Write_Str (Get_Name_String (Fname)); ! Write_Str (""" in mapping file """); ! Write_Str (File_Name); ! Write_Line (""""); Empty_Tables; return; end if; --- 275,322 ---- -- If end of line has been reached, file is truncated ! if First > Last then Report_Truncated; Empty_Tables; return; end if; ! Name_Len := Last - First + 1; ! Name_Buffer (1 .. Name_Len) := SP (First .. Last); Pname := Name_Find; -- Check for duplicate entries if Unit_Hash_Table.Get (Uname) /= No_Entry then ! if not Quiet_Output then ! Write_Str ("warning: duplicate entry """); ! Write_Str (Get_Name_String (Uname)); ! Write_Str (""" in mapping file """); ! Write_Str (File_Name); ! Write_Line (""""); ! The_Mapping := ! File_Mapping.Table (Unit_Hash_Table.Get (Uname)); ! Write_Line (Get_Name_String (The_Mapping.Uname)); ! Write_Line (Get_Name_String (The_Mapping.Fname)); ! end if; ! Empty_Tables; return; end if; if File_Hash_Table.Get (Fname) /= No_Entry then ! if not Quiet_Output then ! Write_Str ("warning: duplicate entry """); ! Write_Str (Get_Name_String (Fname)); ! Write_Str (""" in mapping file """); ! Write_Str (File_Name); ! Write_Line (""""); ! The_Mapping := ! Path_Mapping.Table (File_Hash_Table.Get (Fname)); ! Write_Line (Get_Name_String (The_Mapping.Uname)); ! Write_Line (Get_Name_String (The_Mapping.Fname)); ! end if; ! Empty_Tables; return; end if; *************** package body Fmap is *** 294,299 **** --- 326,336 ---- Add_To_File_Map (Uname, Fname, Pname); end loop; end if; + + -- Record the length of the two mapping tables + + Last_In_Table := File_Mapping.Last; + end Initialize; ---------------------- *************** package body Fmap is *** 307,313 **** if The_Index = No_Entry then return No_File; else ! return File_Mapping.Table (The_Index); end if; end Mapped_File_Name; --- 344,350 ---- if The_Index = No_Entry then return No_File; else ! return File_Mapping.Table (The_Index).Fname; end if; end Mapped_File_Name; *************** package body Fmap is *** 324,331 **** if Index = No_Entry then return No_File; else ! return Path_Mapping.Table (Index); end if; end Mapped_Path_Name; end Fmap; --- 361,443 ---- if Index = No_Entry then return No_File; else ! return Path_Mapping.Table (Index).Fname; end if; end Mapped_Path_Name; + ------------------------- + -- Update_Mapping_File -- + ------------------------- + + procedure Update_Mapping_File (File_Name : String) is + File : File_Descriptor; + + procedure Put_Line (Name : Name_Id); + -- Put Name as a line in the Mapping File + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (Name : Name_Id) is + N_Bytes : Integer; + begin + Get_Name_String (Name); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + N_Bytes := Write (File, Name_Buffer (1)'Address, Name_Len); + + if N_Bytes < Name_Len then + Fail ("disk full"); + end if; + + end Put_Line; + + -- Start of Update_Mapping_File + + begin + + -- Only Update if there are new entries in the mappings + + if Last_In_Table < File_Mapping.Last then + + -- If the tables have been emptied, recreate the file. + -- Otherwise, append to it. + + if Last_In_Table = 0 then + declare + Discard : Boolean; + + begin + Delete_File (File_Name, Discard); + end; + + File := Create_File (File_Name, Binary); + + else + File := Open_Read_Write (Name => File_Name, Fmode => Binary); + end if; + + if File /= Invalid_FD then + if Last_In_Table > 0 then + Lseek (File, 0, Seek_End); + end if; + + for Unit in Last_In_Table + 1 .. File_Mapping.Last loop + Put_Line (File_Mapping.Table (Unit).Uname); + Put_Line (File_Mapping.Table (Unit).Fname); + Put_Line (Path_Mapping.Table (Unit).Fname); + end loop; + + Close (File); + + elsif not Quiet_Output then + Write_Str ("warning: could not open mapping file """); + Write_Str (File_Name); + Write_Line (""" for update"); + end if; + + end if; + end Update_Mapping_File; + end Fmap; diff -Nrc3pad gcc-3.2.3/gcc/ada/fmap.ads gcc-3.3/gcc/ada/fmap.ads *** gcc-3.2.3/gcc/ada/fmap.ads 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fmap.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2.14.1 $ -- -- -- Copyright (C) 2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package Fmap is *** 37,42 **** --- 36,43 ---- -- Initialize the mappings from the mapping file File_Name. -- If the mapping file is incorrect (non existent file, truncated file, -- duplicate entries), output a warning and do not initialize the mappings. + -- Record the state of the mapping tables in case Update is called + -- later on. function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type; -- Return the path name mapped to the file name File. *************** package Fmap is *** 52,55 **** --- 53,62 ---- Path_Name : File_Name_Type); -- Add mapping of Unit_Name to File_Name and of File_Name to Path_Name + procedure Update_Mapping_File (File_Name : String); + -- If Add_To_File_Map has been called (after Initialize or any time + -- if Initialize has not been called), append the new entries to the + -- to the mapping file. + -- What is the significance of the parameter File_Name ??? + end Fmap; diff -Nrc3pad gcc-3.2.3/gcc/ada/fname.adb gcc-3.3/gcc/ada/fname.adb *** gcc-3.2.3/gcc/ada/fname.adb 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fname.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/fname.ads gcc-3.3/gcc/ada/fname.ads *** gcc-3.2.3/gcc/ada/fname.ads 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fname.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/fname-sf.adb gcc-3.3/gcc/ada/fname-sf.adb *** gcc-3.2.3/gcc/ada/fname-sf.adb 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fname-sf.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/fname-sf.ads gcc-3.3/gcc/ada/fname-sf.ads *** gcc-3.2.3/gcc/ada/fname-sf.ads 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fname-sf.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.3.10.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/fname-uf.adb gcc-3.3/gcc/ada/fname-uf.adb *** gcc-3.2.3/gcc/ada/fname-uf.adb 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fname-uf.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.4.10.1 $ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body Fname.UF is *** 370,405 **** Fnam := File_Name_Type (Name_Find); ! -- If we are in the first search of the table, then ! -- we check if the file is present, and only accept ! -- the entry if it is indeed present. For the second ! -- search, we accept the entry without this check. ! ! -- If we only have two entries in the table, then there ! -- is no point in seeing if the file exists, since we ! -- will end up accepting it anyway on the second search, ! -- so just quit and accept it now to save time. ! if No_File_Check or else SFN_Patterns.Last = 2 then return Fnam; ! -- Check if file exists and if so, return the entry else Pname := Find_File (Fnam, Source); ! -- Check if file exists and if so, return the entry if Pname /= No_File then -- Add to mapping, so that we don't do another -- path search in Find_File for this file name Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); return Fnam; ! -- This entry does not match after all, because this is ! -- the first search loop, and the file does not exist. else Fnam := No_File; --- 369,411 ---- Fnam := File_Name_Type (Name_Find); ! -- If we are in the second search of the table, we accept ! -- the file name without checking, because we know that ! -- the file does not exist. ! if No_File_Check then return Fnam; ! -- Otherwise we check if the file exists else Pname := Find_File (Fnam, Source); ! -- If it does exist, we add it to the mappings and ! -- return the file name. if Pname /= No_File then -- Add to mapping, so that we don't do another -- path search in Find_File for this file name + -- and, if we use a mapping file, we are ready + -- to update it at the end of this compilation + -- for the benefit of other compilation processes. Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); return Fnam; ! -- If there are only two entries, they are those of ! -- the default GNAT naming scheme. The file does ! -- not exist, but there is no point doing the ! -- second search, because we will end up with the ! -- same file name. Just return the file name. ! ! elsif SFN_Patterns.Last = 2 then ! return Fnam; ! ! -- The file does not exist, but there may be other ! -- naming scheme. Keep on searching. else Fnam := No_File; diff -Nrc3pad gcc-3.2.3/gcc/ada/fname-uf.ads gcc-3.3/gcc/ada/fname-uf.ads *** gcc-3.2.3/gcc/ada/fname-uf.ads 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/fname-uf.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/freeze.adb gcc-3.3/gcc/ada/freeze.adb *** gcc-3.2.3/gcc/ada/freeze.adb 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/freeze.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Exp_Ch11; use Exp_Ch11; *** 36,41 **** --- 35,41 ---- with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Layout; use Layout; + with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; *************** package body Freeze is *** 248,254 **** end if; if Is_Entity_Name (Nam) then ! Call_Name := New_Reference_To (Old_S, Loc); else Call_Name := New_Copy (Name (N)); --- 248,265 ---- end if; if Is_Entity_Name (Nam) then ! ! -- If the renamed entity is a predefined operator, retain full ! -- name to ensure its visibility. ! ! if Ekind (Old_S) = E_Operator ! and then Nkind (Nam) = N_Expanded_Name ! then ! Call_Name := New_Copy (Name (N)); ! else ! Call_Name := New_Reference_To (Old_S, Loc); ! end if; ! else Call_Name := New_Copy (Name (N)); *************** package body Freeze is *** 291,296 **** --- 302,309 ---- -- in the declaration. However, default values that are aggregates -- are rewritten when partially analyzed, so we recover the original -- aggregate to insure that subsequent conformity checking works. + -- Similarly, if the default expression was constant-folded, recover + -- the original expression. Formal := First_Formal (Defining_Entity (Decl)); *************** package body Freeze is *** 308,314 **** Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); end if; ! elsif Nkind (Default_Value (O_Formal)) = N_Aggregate then Set_Expression (Param_Spec, New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); end if; --- 321,330 ---- Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); end if; ! elsif Nkind (Default_Value (O_Formal)) = N_Aggregate ! or else Nkind (Original_Node (Default_Value (O_Formal))) /= ! Nkind (Default_Value (O_Formal)) ! then Set_Expression (Param_Spec, New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); end if; *************** package body Freeze is *** 409,417 **** -- to give a smaller size. function Size_Known (T : Entity_Id) return Boolean; ! -- Recursive function that does all the work. ! -- Is this right??? isn't recursive case already handled??? ! -- certainly yes for normal call, but what about bogus sem_res call??? function Static_Discriminated_Components (T : Entity_Id) return Boolean; -- If T is a constrained subtype, its size is not known if any of its --- 425,431 ---- -- to give a smaller size. function Size_Known (T : Entity_Id) return Boolean; ! -- Recursive function that does all the work function Static_Discriminated_Components (T : Entity_Id) return Boolean; -- If T is a constrained subtype, its size is not known if any of its *************** package body Freeze is *** 468,476 **** if Size_Known_At_Compile_Time (T) then return True; - elsif Error_Posted (T) then - return False; - elsif Is_Scalar_Type (T) or else Is_Task_Type (T) then --- 482,487 ---- *************** package body Freeze is *** 485,490 **** --- 496,507 ---- elsif not Is_Constrained (T) then return False; + -- Don't do any recursion on type with error posted, since + -- we may have a malformed type that leads us into a loop + + elsif Error_Posted (T) then + return False; + elsif not Size_Known (Component_Type (T)) then return False; end if; *************** package body Freeze is *** 541,547 **** and then not Is_Generic_Type (T) and then Present (Underlying_Type (T)) then ! return Size_Known (Underlying_Type (T)); elsif Is_Record_Type (T) then if Is_Class_Wide_Type (T) then --- 558,571 ---- and then not Is_Generic_Type (T) and then Present (Underlying_Type (T)) then ! -- Don't do any recursion on type with error posted, since ! -- we may have a malformed type that leads us into a loop ! ! if Error_Posted (T) then ! return False; ! else ! return Size_Known (Underlying_Type (T)); ! end if; elsif Is_Record_Type (T) then if Is_Class_Wide_Type (T) then *************** package body Freeze is *** 551,556 **** --- 575,586 ---- return Size_Known_At_Compile_Time (Base_Type (T)) and then Static_Discriminated_Components (T); + -- Don't do any recursion on type with error posted, since + -- we may have a malformed type that leads us into a loop + + elsif Error_Posted (T) then + return False; + else declare Packed_Size_Known : Boolean := Is_Packed (T); *************** package body Freeze is *** 1218,1223 **** --- 1248,1264 ---- end if; end; + -- If this is a constrained subtype of an already frozen type, + -- make the subtype frozen as well. It might otherwise be frozen + -- in the wrong scope, and a freeze node on subtype has no effect. + + elsif Is_Access_Type (Etype (Comp)) + and then not Is_Frozen (Designated_Type (Etype (Comp))) + and then Is_Itype (Designated_Type (Etype (Comp))) + and then Is_Frozen (Base_Type (Designated_Type (Etype (Comp)))) + then + Set_Is_Frozen (Designated_Type (Etype (Comp))); + elsif Is_Array_Type (Etype (Comp)) and then Is_Access_Type (Component_Type (Etype (Comp))) and then Present (Parent (Comp)) *************** package body Freeze is *** 1250,1258 **** if Present (CC) then Placed_Component := True; ! if not Size_Known_At_Compile_Time (Underlying_Type (Etype (Comp))) - and then not Inside_A_Generic then Error_Msg_N ("component clause not allowed for variable " & --- 1291,1301 ---- if Present (CC) then Placed_Component := True; ! if Inside_A_Generic then ! null; ! ! elsif not Size_Known_At_Compile_Time (Underlying_Type (Etype (Comp))) then Error_Msg_N ("component clause not allowed for variable " & *************** package body Freeze is *** 1827,1835 **** Next_Index (Indx); end loop; ! -- For base type, propagate flags for component type if Ekind (E) = E_Array_Type then if Is_Controlled (Component_Type (E)) or else Has_Controlled_Component (Ctyp) then --- 1870,1881 ---- Next_Index (Indx); end loop; ! -- Processing that is done only for base types if Ekind (E) = E_Array_Type then + + -- Propagate flags for component type + if Is_Controlled (Component_Type (E)) or else Has_Controlled_Component (Ctyp) then *************** package body Freeze is *** 1839,1856 **** if Has_Unchecked_Union (Component_Type (E)) then Set_Has_Unchecked_Union (E); end if; - end if; ! -- If packing was requested or if the component size was set ! -- explicitly, then see if bit packing is required. This ! -- processing is only done for base types, since all the ! -- representation aspects involved are type-related. This ! -- is not just an optimization, if we start processing the ! -- subtypes, they intefere with the settings on the base ! -- type (this is because Is_Packed has a slightly different ! -- meaning before and after freezing). - if E = Base_Type (E) then declare Csiz : Uint; Esiz : Uint; --- 1885,1900 ---- if Has_Unchecked_Union (Component_Type (E)) then Set_Has_Unchecked_Union (E); end if; ! -- If packing was requested or if the component size was set ! -- explicitly, then see if bit packing is required. This ! -- processing is only done for base types, since all the ! -- representation aspects involved are type-related. This ! -- is not just an optimization, if we start processing the ! -- subtypes, they intefere with the settings on the base ! -- type (this is because Is_Packed has a slightly different ! -- meaning before and after freezing). declare Csiz : Uint; Esiz : Uint; *************** package body Freeze is *** 1939,1944 **** --- 1983,2045 ---- end if; end if; end; + + -- Processing that is done only for subtypes + + else + -- Acquire alignment from base type + + if Unknown_Alignment (E) then + Set_Alignment (E, Alignment (Base_Type (E))); + end if; + end if; + + -- Check one common case of a size given where the array + -- needs to be packed, but was not so the size cannot be + -- honored. This would of course be caught by the backend, + -- and indeed we don't catch all cases. The point is that + -- we can give a better error message in those cases that + -- we do catch with the circuitry here. + + if Present (Size_Clause (E)) + and then Known_Static_Esize (E) + and then not Has_Pragma_Pack (E) + and then Number_Dimensions (E) = 1 + and then not Has_Component_Size_Clause (E) + and then Known_Static_Component_Size (E) + then + declare + Lo, Hi : Node_Id; + Ctyp : constant Entity_Id := Component_Type (E); + + begin + Get_Index_Bounds (First_Index (E), Lo, Hi); + + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + and then Known_Static_RM_Size (Ctyp) + and then RM_Size (Ctyp) < 64 + then + declare + Lov : constant Uint := Expr_Value (Lo); + Hiv : constant Uint := Expr_Value (Hi); + Len : constant Uint := + UI_Max (Uint_0, Hiv - Lov + 1); + + begin + if Esize (E) < Len * Component_Size (E) + and then Esize (E) = Len * RM_Size (Ctyp) + then + Error_Msg_NE + ("size given for& too small", + Size_Clause (E), E); + Error_Msg_N + ("\explicit pragma Pack is required", + Size_Clause (E)); + end if; + end; + end if; + end; end if; -- If any of the index types was an enumeration type with *************** package body Freeze is *** 2241,2250 **** elsif Has_Discriminants (E) and Is_Constrained (E) then - declare Constraint : Elmt_Id; Expr : Node_Id; begin Constraint := First_Elmt (Discriminant_Constraint (E)); --- 2342,2351 ---- elsif Has_Discriminants (E) and Is_Constrained (E) then declare Constraint : Elmt_Id; Expr : Node_Id; + begin Constraint := First_Elmt (Discriminant_Constraint (E)); *************** package body Freeze is *** 2285,2293 **** then declare Prim_List : constant Elist_Id := Primitive_Operations (E); ! Prim : Elmt_Id := First_Elmt (Prim_List); begin while Present (Prim) loop if Convention (Node (Prim)) = Convention_Ada then Set_Convention (Node (Prim), Convention (E)); --- 2386,2395 ---- then declare Prim_List : constant Elist_Id := Primitive_Operations (E); ! Prim : Elmt_Id; begin + Prim := First_Elmt (Prim_List); while Present (Prim) loop if Convention (Node (Prim)) = Convention_Ada then Set_Convention (Node (Prim), Convention (E)); *************** package body Freeze is *** 2299,2304 **** --- 2401,2443 ---- end if; end if; + -- Generate primitive operation references for a tagged type + + if Is_Tagged_Type (E) + and then not Is_Class_Wide_Type (E) + then + declare + Prim_List : constant Elist_Id := Primitive_Operations (E); + Prim : Elmt_Id; + Ent : Entity_Id; + + begin + Prim := First_Elmt (Prim_List); + while Present (Prim) loop + Ent := Node (Prim); + + -- If the operation is derived, get the original for + -- cross-reference purposes (it is the original for + -- which we want the xref, and for which the comes + -- from source test needs to be performed). + + while Present (Alias (Ent)) loop + Ent := Alias (Ent); + end loop; + + Generate_Reference (E, Ent, 'p', Set_Ref => False); + Next_Elmt (Prim); + end loop; + + -- If we get an exception, then something peculiar has happened + -- probably as a result of a previous error. Since this is only + -- for non-critical cross-references, ignore the error. + + exception + when others => null; + end; + end if; + -- Now that all types from which E may depend are frozen, see -- if the size is known at compile time, if it must be unsigned, -- or if strict alignent is required *************** package body Freeze is *** 2316,2324 **** if Has_Size_Clause (E) and then not Size_Known_At_Compile_Time (E) then ! Error_Msg_N ! ("size clause not allowed for variable length type", ! Size_Clause (E)); end if; -- Remaining process is to set/verify the representation information, --- 2455,2468 ---- if Has_Size_Clause (E) and then not Size_Known_At_Compile_Time (E) then ! -- Supress this message if errors posted on E, even if we are ! -- in all errors mode, since this is often a junk message ! ! if not Error_Posted (E) then ! Error_Msg_N ! ("size clause not allowed for variable length type", ! Size_Clause (E)); ! end if; end if; -- Remaining process is to set/verify the representation information, diff -Nrc3pad gcc-3.2.3/gcc/ada/freeze.ads gcc-3.3/gcc/ada/freeze.ads *** gcc-3.2.3/gcc/ada/freeze.ads 2002-05-04 03:28:03.000000000 +0000 --- gcc-3.3/gcc/ada/freeze.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.4.10.1 $ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/frontend.adb gcc-3.3/gcc/ada/frontend.adb *** gcc-3.2.3/gcc/ada/frontend.adb 2002-05-04 03:28:05.000000000 +0000 --- gcc-3.3/gcc/ada/frontend.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** begin *** 292,304 **** -- make sure that all the necessary information is at hand. Exp_Ch11.Generate_Unit_Exception_Table; - - -- Save the unit name and list of packages named in Use_Package - -- clauses for subsequent use in generating a special symbol for - -- the debugger for certain targets that require this. - - Exp_Dbug.Save_Unitname_And_Use_List - (Cunit (Main_Unit), Nkind (Unit (Cunit (Main_Unit)))); end if; -- List library units if requested --- 291,296 ---- *************** begin *** 328,331 **** --- 320,331 ---- -- of -gnatD, where it rewrites all source locations in the tree. Sprint.Source_Dump; + + -- If a mapping file has been specified by a -gnatem switch, + -- update it if there has been some sourcs that were not in the mappings. + + if Mapping_File_Name /= null then + Fmap.Update_Mapping_File (Mapping_File_Name.all); + end if; + end Frontend; diff -Nrc3pad gcc-3.2.3/gcc/ada/frontend.ads gcc-3.3/gcc/ada/frontend.ads *** gcc-3.2.3/gcc/ada/frontend.ads 2002-05-07 08:22:13.000000000 +0000 --- gcc-3.3/gcc/ada/frontend.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-awk.adb gcc-3.3/gcc/ada/g-awk.adb *** gcc-3.2.3/gcc/ada/g-awk.adb 2001-10-28 12:55:50.000000000 +0000 --- gcc-3.3/gcc/ada/g-awk.adb 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- *************** package body GNAT.AWK is *** 383,388 **** --- 382,389 ---- (A : Simple_Action; Session : Session_Type) is + pragma Warnings (Off, Session); + begin A.Proc.all; end Call; *************** package body GNAT.AWK is *** 446,451 **** --- 447,454 ---- Session : Session_Type) return Boolean is + pragma Warnings (Off, Session); + begin return P.Pattern.all; end Match; *************** package body GNAT.AWK is *** 455,460 **** --- 458,465 ---- ------------- procedure Release (P : in out Pattern) is + pragma Warnings (Off, P); + begin null; end Release; *************** package body GNAT.AWK is *** 907,920 **** Read_Line (Session); Split_Line (Session); ! if Callbacks in Only .. Pass_Through then ! Filter_Active := Apply_Filters (Session); ! end if; ! exit when Callbacks = None ! or else Callbacks = Pass_Through ! or else (Callbacks = Only and then not Filter_Active); end loop; end Get_Line; --- 912,931 ---- Read_Line (Session); Split_Line (Session); ! case Callbacks is ! when None => ! exit; ! ! when Only => ! Filter_Active := Apply_Filters (Session); ! exit when not Filter_Active; ! ! when Pass_Through => ! Filter_Active := Apply_Filters (Session); ! exit; + end case; end loop; end Get_Line; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-awk.ads gcc-3.3/gcc/ada/g-awk.ads *** gcc-3.2.3/gcc/ada/g-awk.ads 2001-10-25 19:56:43.000000000 +0000 --- gcc-3.3/gcc/ada/g-awk.ads 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-busora.adb gcc-3.3/gcc/ada/g-busora.adb *** gcc-3.2.3/gcc/ada/g-busora.adb 2002-05-07 08:22:14.000000000 +0000 --- gcc-3.3/gcc/ada/g-busora.adb 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-busora.ads gcc-3.3/gcc/ada/g-busora.ads *** gcc-3.2.3/gcc/ada/g-busora.ads 2001-10-02 14:15:29.000000000 +0000 --- gcc-3.3/gcc/ada/g-busora.ads 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-busorg.adb gcc-3.3/gcc/ada/g-busorg.adb *** gcc-3.2.3/gcc/ada/g-busorg.adb 2002-05-07 08:22:14.000000000 +0000 --- gcc-3.3/gcc/ada/g-busorg.adb 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-busorg.ads gcc-3.3/gcc/ada/g-busorg.ads *** gcc-3.2.3/gcc/ada/g-busorg.ads 2001-10-02 14:15:29.000000000 +0000 --- gcc-3.3/gcc/ada/g-busorg.ads 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-calend.adb gcc-3.3/gcc/ada/g-calend.adb *** gcc-3.2.3/gcc/ada/g-calend.adb 2001-10-02 14:15:29.000000000 +0000 --- gcc-3.3/gcc/ada/g-calend.adb 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-calend.ads gcc-3.3/gcc/ada/g-calend.ads *** gcc-3.2.3/gcc/ada/g-calend.ads 2002-05-04 03:28:05.000000000 +0000 --- gcc-3.3/gcc/ada/g-calend.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-casuti.adb gcc-3.3/gcc/ada/g-casuti.adb *** gcc-3.2.3/gcc/ada/g-casuti.adb 2002-05-07 08:22:14.000000000 +0000 --- gcc-3.3/gcc/ada/g-casuti.adb 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1995-1999 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-casuti.ads gcc-3.3/gcc/ada/g-casuti.ads *** gcc-3.2.3/gcc/ada/g-casuti.ads 2002-05-07 08:22:15.000000000 +0000 --- gcc-3.3/gcc/ada/g-casuti.ads 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-catiio.adb gcc-3.3/gcc/ada/g-catiio.adb *** gcc-3.2.3/gcc/ada/g-catiio.adb 2001-10-02 14:15:30.000000000 +0000 --- gcc-3.3/gcc/ada/g-catiio.adb 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-catiio.ads gcc-3.3/gcc/ada/g-catiio.ads *** gcc-3.2.3/gcc/ada/g-catiio.ads 2001-10-02 14:15:30.000000000 +0000 --- gcc-3.3/gcc/ada/g-catiio.ads 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-cgi.adb gcc-3.3/gcc/ada/g-cgi.adb *** gcc-3.2.3/gcc/ada/g-cgi.adb 2001-10-02 14:15:30.000000000 +0000 --- gcc-3.3/gcc/ada/g-cgi.adb 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-cgi.ads gcc-3.3/gcc/ada/g-cgi.ads *** gcc-3.2.3/gcc/ada/g-cgi.ads 2001-12-16 01:13:40.000000000 +0000 --- gcc-3.3/gcc/ada/g-cgi.ads 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-cgicoo.adb gcc-3.3/gcc/ada/g-cgicoo.adb *** gcc-3.2.3/gcc/ada/g-cgicoo.adb 2001-10-02 14:15:30.000000000 +0000 --- gcc-3.3/gcc/ada/g-cgicoo.adb 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-cgicoo.ads gcc-3.3/gcc/ada/g-cgicoo.ads *** gcc-3.2.3/gcc/ada/g-cgicoo.ads 2001-10-02 14:15:30.000000000 +0000 --- gcc-3.3/gcc/ada/g-cgicoo.ads 2002-03-14 10:59:17.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-cgideb.adb gcc-3.3/gcc/ada/g-cgideb.adb *** gcc-3.2.3/gcc/ada/g-cgideb.adb 2001-10-02 14:15:30.000000000 +0000 --- gcc-3.3/gcc/ada/g-cgideb.adb 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- *************** package body GNAT.CGI.Debug is *** 208,213 **** --- 207,214 ---- ------------ function Header (IO : in Format; Str : in String) return String is + pragma Warnings (Off, IO); + begin return "

" & Str & "

" & NL; end Header; *************** package body GNAT.CGI.Debug is *** 226,231 **** --- 227,234 ---- -------------- function New_Line (IO : in Format) return String is + pragma Warnings (Off, IO); + begin return "
" & NL; end New_Line; *************** package body GNAT.CGI.Debug is *** 235,240 **** --- 238,245 ---- ----------- function Title (IO : in Format; Str : in String) return String is + pragma Warnings (Off, IO); + begin return "

" & Str & "

" & NL; end Title; *************** package body GNAT.CGI.Debug is *** 249,254 **** --- 254,261 ---- Value : String) return String is + pragma Warnings (Off, IO); + begin return Bold (Name) & " = " & Italic (Value); end Variable; *************** package body GNAT.CGI.Debug is *** 275,280 **** --- 282,289 ---- -------------- function New_Line (IO : in Format) return String is + pragma Warnings (Off, IO); + begin return String'(1 => ASCII.LF); end New_Line; *************** package body GNAT.CGI.Debug is *** 301,306 **** --- 310,317 ---- Value : String) return String is + pragma Warnings (Off, IO); + begin return " " & Name & " = " & Value; end Variable; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-cgideb.ads gcc-3.3/gcc/ada/g-cgideb.ads *** gcc-3.2.3/gcc/ada/g-cgideb.ads 2001-10-02 14:15:30.000000000 +0000 --- gcc-3.3/gcc/ada/g-cgideb.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-comlin.adb gcc-3.3/gcc/ada/g-comlin.adb *** gcc-3.2.3/gcc/ada/g-comlin.adb 2002-05-04 03:28:05.000000000 +0000 --- gcc-3.3/gcc/ada/g-comlin.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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- -- --- 6,13 ---- -- -- -- B o d y -- -- -- -- -- ! -- Copyright (C) 1999-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- -- *************** *** 33,38 **** --- 32,38 ---- ------------------------------------------------------------------------------ with Ada.Command_Line; + with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Command_Line is *************** package body GNAT.Command_Line is *** 41,52 **** type Section_Number is new Natural range 0 .. 65534; for Section_Number'Size use 16; ! type Parameter_Type is ! record ! Arg_Num : Positive; ! First : Positive; ! Last : Positive; ! end record; The_Parameter : Parameter_Type; The_Switch : Parameter_Type; -- This type and this variable are provided to store the current switch --- 41,51 ---- type Section_Number is new Natural range 0 .. 65534; for Section_Number'Size use 16; ! type Parameter_Type is record ! Arg_Num : Positive; ! First : Positive; ! Last : Positive; ! end record; The_Parameter : Parameter_Type; The_Switch : Parameter_Type; -- This type and this variable are provided to store the current switch *************** package body GNAT.Command_Line is *** 101,108 **** -- Go to the next argument on the command line. If we are at the end -- of the current section, we want to make sure there is no other -- identical section on the command line (there might be multiple ! -- instances of -largs). ! -- Return True if there as another argument, False otherwise --------------- -- Expansion -- --- 100,138 ---- -- Go to the next argument on the command line. If we are at the end -- of the current section, we want to make sure there is no other -- identical section on the command line (there might be multiple ! -- instances of -largs). Returns True iff there is another argument. ! ! function Get_File_Names_Case_Sensitive return Integer; ! pragma Import (C, Get_File_Names_Case_Sensitive, ! "__gnat_get_file_names_case_sensitive"); ! File_Names_Case_Sensitive : constant Boolean := ! Get_File_Names_Case_Sensitive /= 0; ! ! procedure Canonical_Case_File_Name (S : in out String); ! -- Given a file name, converts it to canonical case form. For systems ! -- where file names are case sensitive, this procedure has no effect. ! -- If file names are not case sensitive (i.e. for example if you have ! -- the file "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then ! -- this call converts the given string to canonical all lower case form, ! -- so that two file names compare equal if they refer to the same file. ! ! ------------------------------ ! -- Canonical_Case_File_Name -- ! ------------------------------ ! ! procedure Canonical_Case_File_Name (S : in out String) is ! begin ! if not File_Names_Case_Sensitive then ! for J in S'Range loop ! if S (J) in 'A' .. 'Z' then ! S (J) := Character'Val ( ! Character'Pos (S (J)) + ! Character'Pos ('a') - ! Character'Pos ('A')); ! end if; ! end loop; ! end if; ! end Canonical_Case_File_Name; --------------- -- Expansion -- *************** package body GNAT.Command_Line is *** 116,132 **** Last : Natural; It : Pointer := Iterator'Unrestricted_Access; begin loop ! Read (It.Dir, S, Last); if Last = 0 then ! Close (It.Dir); ! return String'(1 .. 0 => ' '); ! end if; ! if GNAT.Regexp.Match (S (1 .. Last), Iterator.Regexp) then ! return S (1 .. Last); end if; end loop; --- 146,226 ---- Last : Natural; It : Pointer := Iterator'Unrestricted_Access; + Current : Depth := It.Current_Depth; + NL : Positive; + begin + -- It is assumed that a directory is opened at the current level; + -- otherwise, GNAT.Directory_Operations.Directory_Error will be raised + -- at the first call to Read. + loop ! Read (It.Levels (Current).Dir, S, Last); ! ! -- If we have exhausted the directory, close it and go back one level if Last = 0 then ! Close (It.Levels (Current).Dir); ! -- If we are at level 1, we are finished; return an empty string. ! ! if Current = 1 then ! return String'(1 .. 0 => ' '); ! else ! -- Otherwise, continue with the directory at the previous level ! ! Current := Current - 1; ! It.Current_Depth := Current; ! end if; ! ! -- If this is a directory, that is neither "." or "..", attempt to ! -- go to the next level. ! ! elsif Is_Directory ! (It.Dir_Name (1 .. It.Levels (Current).Name_Last) & S (1 .. Last)) ! and then S (1 .. Last) /= "." ! and then S (1 .. Last) /= ".." ! then ! -- We can go to the next level only if we have not reached the ! -- maximum depth, ! ! if Current < It.Maximum_Depth then ! NL := It.Levels (Current).Name_Last; ! ! -- And if relative path of this new directory is not too long ! ! if NL + Last + 1 < Max_Path_Length then ! Current := Current + 1; ! It.Current_Depth := Current; ! It.Dir_Name (NL + 1 .. NL + Last) := S (1 .. Last); ! NL := NL + Last + 1; ! It.Dir_Name (NL) := Directory_Separator; ! It.Levels (Current).Name_Last := NL; ! Canonical_Case_File_Name (It.Dir_Name (1 .. NL)); ! ! -- Open the new directory, and read from it ! ! GNAT.Directory_Operations.Open ! (It.Levels (Current).Dir, It.Dir_Name (1 .. NL)); ! end if; ! end if; ! ! -- If not a directory, check the relative path against the pattern ! ! else ! declare ! Name : String := ! It.Dir_Name (It.Start .. It.Levels (Current).Name_Last) & ! S (1 .. Last); ! begin ! Canonical_Case_File_Name (Name); ! ! -- If it matches, return the relative path ! ! if GNAT.Regexp.Match (Name, Iterator.Regexp) then ! return Name; ! end if; ! end; end if; end loop; *************** package body GNAT.Command_Line is *** 155,167 **** if In_Expansion then declare S : String := Expansion (Expansion_It); begin if S'Length /= 0 then return S; else In_Expansion := False; end if; - end; end if; --- 249,261 ---- if In_Expansion then declare S : String := Expansion (Expansion_It); + begin if S'Length /= 0 then return S; else In_Expansion := False; end if; end; end if; *************** package body GNAT.Command_Line is *** 206,212 **** Current_Argument := Current_Argument + 1; ! -- Could it be a file name with wild cards to expand ? if Do_Expansion then declare --- 300,306 ---- Current_Argument := Current_Argument + 1; ! -- Could it be a file name with wild cards to expand? if Do_Expansion then declare *************** package body GNAT.Command_Line is *** 238,253 **** ------------ function Getopt (Switches : String) return Character is ! Dummy : Boolean; begin ! -- If we have finished to parse the current command line item (there -- might be multiple switches in a single item), then go to the next -- element if Current_Argument > CL.Argument_Count or else (Current_Index > CL.Argument (Current_Argument)'Last ! and then not Goto_Next_Argument_In_Section) then return ASCII.NUL; end if; --- 332,347 ---- ------------ function Getopt (Switches : String) return Character is ! Dummy : Boolean; begin ! -- If we have finished parsing the current command line item (there -- might be multiple switches in a single item), then go to the next -- element if Current_Argument > CL.Argument_Count or else (Current_Index > CL.Argument (Current_Argument)'Last ! and then not Goto_Next_Argument_In_Section) then return ASCII.NUL; end if; *************** package body GNAT.Command_Line is *** 302,310 **** Length := Length + 1; end loop; ! if (Switches (Length - 1) = ':' ! or else Switches (Length - 1) = '?' ! or else Switches (Length - 1) = '!') and then Length > Index + 1 then Length := Length - 1; --- 396,405 ---- Length := Length + 1; end loop; ! if (Switches (Length - 1) = ':' or else ! Switches (Length - 1) = '=' or else ! Switches (Length - 1) = '?' or else ! Switches (Length - 1) = '!') and then Length > Index + 1 then Length := Length - 1; *************** package body GNAT.Command_Line is *** 314,321 **** if Current_Index + Length - 1 - Index <= Arg'Last and then ! Switches (Index .. Length - 1) = ! Arg (Current_Index .. Current_Index + Length - 1 - Index) and then Length - Index > Max_Length then Index_Switches := Index; --- 409,416 ---- if Current_Index + Length - 1 - Index <= Arg'Last and then ! Switches (Index .. Length - 1) = ! Arg (Current_Index .. Current_Index + Length - 1 - Index) and then Length - Index > Max_Length then Index_Switches := Index; *************** package body GNAT.Command_Line is *** 323,340 **** end if; -- Look for the next switch in Switches while Index <= Switches'Last and then Switches (Index) /= ' ' loop Index := Index + 1; end loop; - Index := Index + 1; end loop; End_Index := Current_Index + Max_Length - 1; ! -- If the switch is not accepted, skip it, unless we had a '*' in ! -- Switches if Index_Switches = 0 then if Switches (Switches'First) = '*' then --- 418,435 ---- end if; -- Look for the next switch in Switches + while Index <= Switches'Last and then Switches (Index) /= ' ' loop Index := Index + 1; end loop; + Index := Index + 1; end loop; End_Index := Current_Index + Max_Length - 1; ! -- If switch is not accepted, skip it, unless we had '*' in Switches if Index_Switches = 0 then if Switches (Switches'First) = '*' then *************** package body GNAT.Command_Line is *** 360,366 **** First => Current_Index, Last => End_Index); ! -- If switch needs an argument if Index_Switches + Max_Length <= Switches'Last then --- 455,461 ---- First => Current_Index, Last => End_Index); ! -- Case of switch needs an argument if Index_Switches + Max_Length <= Switches'Last then *************** package body GNAT.Command_Line is *** 390,395 **** --- 485,527 ---- raise Invalid_Parameter; end if; + when '=' => + + -- If the switch is of the form =xxx + + if End_Index < Arg'Last then + + if Arg (End_Index + 1) = '=' + and then End_Index + 1 < Arg'Last + then + Set_Parameter (The_Parameter, + Arg_Num => Current_Argument, + First => End_Index + 2, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section; + + else + Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + -- If the switch is of the form xxx + + elsif Section (Current_Argument + 1) /= 0 then + Set_Parameter + (The_Parameter, + Arg_Num => Current_Argument + 1, + First => 1, + Last => CL.Argument (Current_Argument + 1)'Last); + Current_Argument := Current_Argument + 1; + Is_Switch (Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section; + + else + Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + when '!' => if End_Index < Arg'Last then *************** package body GNAT.Command_Line is *** 447,452 **** --- 579,585 ---- if Current_Argument > CL.Argument_Count then return False; end if; + Current_Argument := Current_Argument + 1; exit when Section (Current_Argument) = Current_Section; end loop; *************** package body GNAT.Command_Line is *** 478,483 **** --- 611,617 ---- then Current_Argument := Index + 1; Current_Index := 1; + if Current_Argument <= CL.Argument_Count then Current_Section := Section (Current_Argument); end if; *************** package body GNAT.Command_Line is *** 486,491 **** --- 620,626 ---- Index := Index + 1; end loop; + Current_Argument := Positive'Last; Current_Index := 2; -- so that Get_Argument returns nothing end Goto_Section; *************** package body GNAT.Command_Line is *** 529,536 **** for Index in 1 .. CL.Argument_Count loop if CL.Argument (Index)(1) = Switch_Character ! and then CL.Argument (Index) = Switch_Character ! & Section_Delimiters (Section_Index .. Last - 1) then Section (Index) := 0; Delimiter_Found := True; --- 664,673 ---- for Index in 1 .. CL.Argument_Count loop if CL.Argument (Index)(1) = Switch_Character ! and then ! CL.Argument (Index) = Switch_Character & ! Section_Delimiters ! (Section_Index .. Last - 1) then Section (Index) := 0; Delimiter_Found := True; *************** package body GNAT.Command_Line is *** 576,582 **** (Variable : out Parameter_Type; Arg_Num : Positive; First : Positive; ! Last : Positive) is begin Variable.Arg_Num := Arg_Num; Variable.First := First; --- 713,720 ---- (Variable : out Parameter_Type; Arg_Num : Positive; First : Positive; ! Last : Positive) ! is begin Variable.Arg_Num := Arg_Num; Variable.First := First; *************** package body GNAT.Command_Line is *** 595,610 **** is Directory_Separator : Character; pragma Import (C, Directory_Separator, "__gnat_dir_separator"); begin if Directory = "" then ! GNAT.Directory_Operations.Open ! (Iterator.Dir, "." & Directory_Separator); else ! GNAT.Directory_Operations.Open (Iterator.Dir, Directory); end if; ! Iterator.Regexp := GNAT.Regexp.Compile (Pattern, Basic_Regexp, True); end Start_Expansion; begin --- 733,796 ---- is Directory_Separator : Character; pragma Import (C, Directory_Separator, "__gnat_dir_separator"); + First : Positive := Pattern'First; + + Pat : String := Pattern; begin + Canonical_Case_File_Name (Pat); + Iterator.Current_Depth := 1; + + -- If Directory is unspecified, use the current directory ("./" or ".\") + if Directory = "" then ! Iterator.Dir_Name (1 .. 2) := "." & Directory_Separator; ! Iterator.Start := 3; ! else ! Iterator.Dir_Name (1 .. Directory'Length) := Directory; ! Iterator.Start := Directory'Length + 1; ! Canonical_Case_File_Name (Iterator.Dir_Name (1 .. Directory'Length)); ! ! -- Make sure that the last character is a directory separator ! ! if Directory (Directory'Last) /= Directory_Separator then ! Iterator.Dir_Name (Iterator.Start) := Directory_Separator; ! Iterator.Start := Iterator.Start + 1; ! end if; end if; ! Iterator.Levels (1).Name_Last := Iterator.Start - 1; ! ! -- Open the initial Directory, at depth 1 ! ! GNAT.Directory_Operations.Open ! (Iterator.Levels (1).Dir, Iterator.Dir_Name (1 .. Iterator.Start - 1)); ! ! -- If in the current directory and the pattern starts with "./", ! -- drop the "./" from the pattern. ! ! if Directory = "" and then Pat'Length > 2 ! and then Pat (Pat'First .. Pat'First + 1) = "./" ! then ! First := Pat'First + 2; ! end if; ! ! Iterator.Regexp := ! GNAT.Regexp.Compile (Pat (First .. Pat'Last), Basic_Regexp, True); ! ! Iterator.Maximum_Depth := 1; ! ! -- Maximum_Depth is equal to 1 plus the number of directory separators ! -- in the pattern. ! ! for Index in First .. Pat'Last loop ! if Pat (Index) = Directory_Separator then ! Iterator.Maximum_Depth := Iterator.Maximum_Depth + 1; ! exit when Iterator.Maximum_Depth = Max_Depth; ! end if; ! end loop; ! end Start_Expansion; begin diff -Nrc3pad gcc-3.2.3/gcc/ada/g-comlin.ads gcc-3.3/gcc/ada/g-comlin.ads *** gcc-3.2.3/gcc/ada/g-comlin.ads 2001-12-13 00:03:51.000000000 +0000 --- gcc-3.3/gcc/ada/g-comlin.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.3 $ -- -- ! -- 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- -- --- 6,13 ---- -- -- -- S p e c -- -- -- -- -- ! -- 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- -- *************** *** 36,54 **** -- This package provides an interface to Ada.Command_Line, to do the -- parsing of command line arguments. Here is a small usage example: ! -- -- begin -- loop -- case Getopt ("a b: ad") is -- Accepts '-a', '-ad', or '-b argument' -- when ASCII.NUL => exit; ! -- -- when 'a' => -- if Full_Switch = "a" then -- Put_Line ("Got a"); -- else -- Put_Line ("Got ad"); -- end if; ! -- -- when 'b' => -- Put_Line ("Got b + " & Parameter); -- --- 35,53 ---- -- This package provides an interface to Ada.Command_Line, to do the -- parsing of command line arguments. Here is a small usage example: ! -- begin -- loop -- case Getopt ("a b: ad") is -- Accepts '-a', '-ad', or '-b argument' -- when ASCII.NUL => exit; ! -- when 'a' => -- if Full_Switch = "a" then -- Put_Line ("Got a"); -- else -- Put_Line ("Got ad"); -- end if; ! -- when 'b' => -- Put_Line ("Got b + " & Parameter); -- *************** *** 56,66 **** -- raise Program_Error; -- cannot occur! -- end case; -- end loop; ! -- -- loop -- declare -- S : constant String := Get_Argument (Do_Expansion => True); - -- begin -- exit when S'Length = 0; -- Put_Line ("Got " & S); --- 55,64 ---- -- raise Program_Error; -- cannot occur! -- end case; -- end loop; ! -- loop -- declare -- S : constant String := Get_Argument (Do_Expansion => True); -- begin -- exit when S'Length = 0; -- Put_Line ("Got " & S); *************** *** 71,97 **** -- when Invalid_Switch => Put_Line ("Invalid Switch " & Full_Switch); -- when Invalid_Parameter => Put_Line ("No parameter for " & Full_Switch); -- end; ! -- -- A more complicated example would involve the use of sections for the -- switches, as for instance in gnatmake. These sections are separated by -- special switches, chosen by the programer. Each section act as a -- command line of its own. ! -- -- begin -- Initialize_Option_Scan ('-', False, "largs bargs cargs"); -- loop ! -- -- same loop as above to get switches and arguments -- end loop; ! -- -- Goto_Section ("bargs"); -- loop ! -- -- same loop as above to get switches and arguments -- -- The supports switches in Get_Opt might be different -- end loop; ! -- -- Goto_Section ("cargs"); -- loop ! -- -- same loop as above to get switches and arguments -- -- The supports switches in Get_Opt might be different -- end loop; -- end; --- 69,95 ---- -- when Invalid_Switch => Put_Line ("Invalid Switch " & Full_Switch); -- when Invalid_Parameter => Put_Line ("No parameter for " & Full_Switch); -- end; ! -- A more complicated example would involve the use of sections for the -- switches, as for instance in gnatmake. These sections are separated by -- special switches, chosen by the programer. Each section act as a -- command line of its own. ! -- begin -- Initialize_Option_Scan ('-', False, "largs bargs cargs"); -- loop ! -- -- Same loop as above to get switches and arguments -- end loop; ! -- Goto_Section ("bargs"); -- loop ! -- -- Same loop as above to get switches and arguments -- -- The supports switches in Get_Opt might be different -- end loop; ! -- Goto_Section ("cargs"); -- loop ! -- -- Same loop as above to get switches and arguments -- -- The supports switches in Get_Opt might be different -- end loop; -- end; *************** package GNAT.Command_Line is *** 161,166 **** --- 159,166 ---- -- -- ':' The switch requires a parameter. There can optionally be a space -- on the command line between the switch and its parameter + -- '=' The switch requires a parameter. There can either be a '=' or a + -- space on the command line between the switch and its parameter -- '!' The switch requires a parameter, but there can be no space on the -- command line between the switch and its parameter -- '?' The switch may have an optional parameter. There can no space *************** package GNAT.Command_Line is *** 238,253 **** Pattern : String; Directory : String := ""; Basic_Regexp : Boolean := True); ! -- Initialize an wild card expansion. The next calls to Expansion will -- return the next file name in Directory which match Pattern (Pattern -- is a regular expression, using only the Unix shell and DOS syntax if ! -- Basic_Regexp is True. When Directory is an empty string, the current -- directory is searched. function Expansion (Iterator : Expansion_Iterator) return String; -- Return the next file in the directory matching the parameters given -- to Start_Expansion and updates Iterator to point to the next entry. ! -- Returns an empty string when there are no more files in the directory. -- If Expansion is called again after an empty string has been returned, -- then the exception GNAT.Directory_Operations.Directory_Error is raised. --- 238,264 ---- Pattern : String; Directory : String := ""; Basic_Regexp : Boolean := True); ! -- Initialize a wild card expansion. The next calls to Expansion will -- return the next file name in Directory which match Pattern (Pattern -- is a regular expression, using only the Unix shell and DOS syntax if ! -- Basic_Regexp is True). When Directory is an empty string, the current -- directory is searched. + -- + -- Pattern may contains directory separators (as in "src/*/*.ada"). + -- Subdirectories of Directory will also be searched, up to one + -- hundred levels deep. + -- + -- When Start_Expansion has been called, function Expansion should be + -- called repetitively until it returns an empty string, before + -- Start_Expansion can be called again with the same Expansion_Iterator + -- variable. function Expansion (Iterator : Expansion_Iterator) return String; -- Return the next file in the directory matching the parameters given -- to Start_Expansion and updates Iterator to point to the next entry. ! -- Returns an empty string when there are no more files in the directory ! -- and its subdirectories. ! -- -- If Expansion is called again after an empty string has been returned, -- then the exception GNAT.Directory_Operations.Directory_Error is raised. *************** package GNAT.Command_Line is *** 263,271 **** private type Expansion_Iterator is limited record ! Dir : GNAT.Directory_Operations.Dir_Type; Regexp : GNAT.Regexp.Regexp; end record; end GNAT.Command_Line; --- 274,312 ---- private + Max_Depth : constant := 100; + -- Maximum depth of subdirectories + + Max_Path_Length : constant := 1024; + -- Maximum length of relative path + + type Depth is range 1 .. Max_Depth; + + type Level is record + Name_Last : Natural := 0; + Dir : GNAT.Directory_Operations.Dir_Type; + end record; + + type Level_Array is array (Depth) of Level; + type Expansion_Iterator is limited record ! Start : Positive := 1; ! -- Position of the first character of the relative path to check ! -- against the pattern. ! ! Dir_Name : String (1 .. Max_Path_Length); ! ! Current_Depth : Depth := 1; ! ! Levels : Level_Array; ! Regexp : GNAT.Regexp.Regexp; + -- Regular expression built with the pattern + + Maximum_Depth : Depth := 1; + -- The maximum depth of directories, reflecting the number of + -- directory separators in the pattern. + end record; end GNAT.Command_Line; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-crc32.adb gcc-3.3/gcc/ada/g-crc32.adb *** gcc-3.2.3/gcc/ada/g-crc32.adb 2001-10-11 23:28:47.000000000 +0000 --- gcc-3.3/gcc/ada/g-crc32.adb 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-crc32.ads gcc-3.3/gcc/ada/g-crc32.ads *** gcc-3.2.3/gcc/ada/g-crc32.ads 2001-10-11 23:28:47.000000000 +0000 --- gcc-3.3/gcc/ada/g-crc32.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-curexc.ads gcc-3.3/gcc/ada/g-curexc.ads *** gcc-3.2.3/gcc/ada/g-curexc.ads 2002-05-07 08:22:15.000000000 +0000 --- gcc-3.3/gcc/ada/g-curexc.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1996-2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-debpoo.adb gcc-3.3/gcc/ada/g-debpoo.adb *** gcc-3.2.3/gcc/ada/g-debpoo.adb 2002-05-04 03:28:05.000000000 +0000 --- gcc-3.3/gcc/ada/g-debpoo.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body GNAT.Debug_Pools is *** 68,74 **** (Pool : in out Debug_Pool; Storage_Address : out Address; Size_In_Storage_Elements : Storage_Count; ! Alignment : Storage_Count) is begin Storage_Address := Alloc (size_t (Size_In_Storage_Elements)); --- 67,76 ---- (Pool : in out Debug_Pool; Storage_Address : out Address; Size_In_Storage_Elements : Storage_Count; ! Alignment : Storage_Count) ! is ! pragma Warnings (Off, Alignment); ! begin Storage_Address := Alloc (size_t (Size_In_Storage_Elements)); *************** package body GNAT.Debug_Pools is *** 94,101 **** Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count) is procedure Free (Address : System.Address; Siz : Storage_Count); ! -- Faked free, that reset all the deallocated storage to "DEADBEEF" procedure Free (Address : System.Address; Siz : Storage_Count) is DB1 : constant Integer := 16#DEAD#; --- 96,105 ---- Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count) is + pragma Warnings (Off, Alignment); + procedure Free (Address : System.Address; Siz : Storage_Count); ! -- Fake free, that resets all the deallocated storage to "DEADBEEF" procedure Free (Address : System.Address; Siz : Storage_Count) is DB1 : constant Integer := 16#DEAD#; *************** package body GNAT.Debug_Pools is *** 151,156 **** --- 155,164 ---- Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count) is + pragma Warnings (Off, Pool); + pragma Warnings (Off, Size_In_Storage_Elements); + pragma Warnings (Off, Alignment); + S : State := Table.Get (Storage_Address); Max_Dim : constant := 3; Dim : Integer := 1; *************** package body GNAT.Debug_Pools is *** 216,221 **** --- 224,231 ---- ------------------ function Storage_Size (Pool : Debug_Pool) return Storage_Count is + pragma Warnings (Off, Pool); + begin return Storage_Count'Last; end Storage_Size; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-debpoo.ads gcc-3.3/gcc/ada/g-debpoo.ads *** gcc-3.2.3/gcc/ada/g-debpoo.ads 2002-05-04 03:28:05.000000000 +0000 --- gcc-3.3/gcc/ada/g-debpoo.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-debuti.adb gcc-3.3/gcc/ada/g-debuti.adb *** gcc-3.2.3/gcc/ada/g-debuti.adb 2002-05-07 08:22:15.000000000 +0000 --- gcc-3.3/gcc/ada/g-debuti.adb 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-1998 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-debuti.ads gcc-3.3/gcc/ada/g-debuti.ads *** gcc-3.2.3/gcc/ada/g-debuti.ads 2002-05-07 08:22:15.000000000 +0000 --- gcc-3.3/gcc/ada/g-debuti.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-diopit.adb gcc-3.3/gcc/ada/g-diopit.adb *** gcc-3.2.3/gcc/ada/g-diopit.adb 2001-12-11 22:50:45.000000000 +0000 --- gcc-3.3/gcc/ada/g-diopit.adb 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-diopit.ads gcc-3.3/gcc/ada/g-diopit.ads *** gcc-3.2.3/gcc/ada/g-diopit.ads 2001-12-11 22:50:45.000000000 +0000 --- gcc-3.3/gcc/ada/g-diopit.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-dirope.adb gcc-3.3/gcc/ada/g-dirope.adb *** gcc-3.2.3/gcc/ada/g-dirope.adb 2001-12-12 21:26:45.000000000 +0000 --- gcc-3.3/gcc/ada/g-dirope.adb 2002-05-31 18:08:22.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.6 $ -- -- -- Copyright (C) 1998-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- *************** package body GNAT.Directory_Operations i *** 460,470 **** end File_Name; --------------------- -- Get_Current_Dir -- --------------------- Max_Path : Integer; ! pragma Import (C, Max_Path, "max_path_len"); function Get_Current_Dir return Dir_Name_Str is Current_Dir : String (1 .. Max_Path + 1); --- 459,508 ---- end File_Name; --------------------- + -- Format_Pathname -- + --------------------- + + function Format_Pathname + (Path : Path_Name; + Style : Path_Style := System_Default) + return String + is + N_Path : String := Path; + K : Positive := N_Path'First; + Prev_Dirsep : Boolean := False; + + begin + for J in Path'Range loop + + if Strings.Maps.Is_In (Path (J), Dir_Seps) then + if not Prev_Dirsep then + case Style is + when UNIX => N_Path (K) := '/'; + when DOS => N_Path (K) := '\'; + when System_Default => N_Path (K) := Dir_Separator; + end case; + + K := K + 1; + end if; + + Prev_Dirsep := True; + + else + N_Path (K) := Path (J); + K := K + 1; + Prev_Dirsep := False; + end if; + end loop; + + return N_Path (N_Path'First .. K - 1); + end Format_Pathname; + + --------------------- -- Get_Current_Dir -- --------------------- Max_Path : Integer; ! pragma Import (C, Max_Path, "__gnat_max_path_len"); function Get_Current_Dir return Dir_Name_Str is Current_Dir : String (1 .. Max_Path + 1); *************** package body GNAT.Directory_Operations i *** 522,567 **** end if; end Make_Dir; - ------------------------ - -- Normalize_Pathname -- - ------------------------ - - function Normalize_Pathname - (Path : Path_Name; - Style : Path_Style := System_Default) - return String - is - N_Path : String := Path; - K : Positive := N_Path'First; - Prev_Dirsep : Boolean := False; - - begin - for J in Path'Range loop - - if Strings.Maps.Is_In (Path (J), Dir_Seps) then - if not Prev_Dirsep then - - case Style is - when UNIX => N_Path (K) := '/'; - when DOS => N_Path (K) := '\'; - when System_Default => N_Path (K) := Dir_Separator; - end case; - - K := K + 1; - end if; - - Prev_Dirsep := True; - - else - N_Path (K) := Path (J); - K := K + 1; - Prev_Dirsep := False; - end if; - end loop; - - return N_Path (N_Path'First .. K - 1); - end Normalize_Pathname; - ---------- -- Open -- ---------- --- 560,565 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-dirope.ads gcc-3.3/gcc/ada/g-dirope.ads *** gcc-3.2.3/gcc/ada/g-dirope.ads 2001-12-12 21:26:44.000000000 +0000 --- gcc-3.3/gcc/ada/g-dirope.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 1998-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- *************** package GNAT.Directory_Operations is *** 136,142 **** type Path_Style is (UNIX, DOS, System_Default); ! function Normalize_Pathname (Path : Path_Name; Style : Path_Style := System_Default) return Path_Name; --- 135,141 ---- type Path_Style is (UNIX, DOS, System_Default); ! function Format_Pathname (Path : Path_Name; Style : Path_Style := System_Default) return Path_Name; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-dyntab.adb gcc-3.3/gcc/ada/g-dyntab.adb *** gcc-3.2.3/gcc/ada/g-dyntab.adb 2001-10-02 14:15:30.000000000 +0000 --- gcc-3.3/gcc/ada/g-dyntab.adb 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- *************** *** 32,46 **** -- -- ------------------------------------------------------------------------------ ! with System; use System; package body GNAT.Dynamic_Tables is Min : constant Integer := Integer (Table_Low_Bound); -- Subscript of the minimum entry in the currently allocated table - type size_t is new Integer; - ----------------------- -- Local Subprograms -- ----------------------- --- 31,45 ---- -- -- ------------------------------------------------------------------------------ ! with System; use System; ! with System.Memory; use System.Memory; ! with System.Address_To_Access_Conversions; package body GNAT.Dynamic_Tables is Min : constant Integer := Integer (Table_Low_Bound); -- Subscript of the minimum entry in the currently allocated table ----------------------- -- Local Subprograms -- ----------------------- *************** package body GNAT.Dynamic_Tables is *** 50,55 **** --- 49,66 ---- -- in Max. Works correctly to do an initial allocation if the table -- is currently null. + package Table_Conversions is + new System.Address_To_Access_Conversions (Big_Table_Type); + -- Address and Access conversions for a Table object. + + function To_Address (Table : Table_Ptr) return Address; + pragma Inline (To_Address); + -- Returns the Address for the Table object. + + function To_Pointer (Table : Address) return Table_Ptr; + pragma Inline (To_Pointer); + -- Returns the Access pointer for the Table object. + -------------- -- Allocate -- -------------- *************** package body GNAT.Dynamic_Tables is *** 90,100 **** ---------- procedure Free (T : in out Instance) is - procedure free (T : Table_Ptr); - pragma Import (C, free); - begin ! free (T.Table); T.Table := null; T.P.Length := 0; end Free; --- 101,108 ---- ---------- procedure Free (T : in out Instance) is begin ! Free (To_Address (T.Table)); T.Table := null; T.P.Length := 0; end Free; *************** package body GNAT.Dynamic_Tables is *** 155,172 **** ---------------- procedure Reallocate (T : in out Instance) is - - function realloc - (memblock : Table_Ptr; - size : size_t) - return Table_Ptr; - pragma Import (C, realloc); - - function malloc - (size : size_t) - return Table_Ptr; - pragma Import (C, malloc); - New_Size : size_t; begin --- 163,168 ---- *************** package body GNAT.Dynamic_Tables is *** 182,194 **** (Table_Type'Component_Size / Storage_Unit)); if T.Table = null then ! T.Table := malloc (New_Size); elsif New_Size > 0 then T.Table := ! realloc ! (memblock => T.Table, ! size => New_Size); end if; if T.P.Length /= 0 and then T.Table = null then --- 178,189 ---- (Table_Type'Component_Size / Storage_Unit)); if T.Table = null then ! T.Table := To_Pointer (Alloc (New_Size)); elsif New_Size > 0 then T.Table := ! To_Pointer (Realloc (Ptr => To_Address (T.Table), ! Size => New_Size)); end if; if T.P.Length /= 0 and then T.Table = null then *************** package body GNAT.Dynamic_Tables is *** 243,246 **** --- 238,260 ---- end if; end Set_Last; + ---------------- + -- To_Address -- + ---------------- + + function To_Address (Table : Table_Ptr) return Address is + begin + return Table_Conversions.To_Address + (Table_Conversions.Object_Pointer (Table)); + end To_Address; + + ---------------- + -- To_Pointer -- + ---------------- + + function To_Pointer (Table : Address) return Table_Ptr is + begin + return Table_Ptr (Table_Conversions.To_Pointer (Table)); + end To_Pointer; + end GNAT.Dynamic_Tables; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-dyntab.ads gcc-3.3/gcc/ada/g-dyntab.ads *** gcc-3.2.3/gcc/ada/g-dyntab.ads 2001-10-28 12:55:50.000000000 +0000 --- gcc-3.3/gcc/ada/g-dyntab.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-enblsp.adb gcc-3.3/gcc/ada/g-enblsp.adb *** gcc-3.2.3/gcc/ada/g-enblsp.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/g-enblsp.adb 2002-03-14 10:59:18.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT LIBRARY COMPONENTS -- + -- -- + -- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N -- + -- -- + -- B o d y -- + -- -- + -- -- + -- Copyright (C) 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the default version. Used everywhere except VMS. + + separate (GNAT.Expect) + 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 Fork return Process_Id; + pragma Import (C, Fork, "__gnat_expect_fork"); + -- Starts a new process if possible. + -- See the Unix command fork for more information. On systems that + -- don't support this capability (Windows...), this command does + -- nothing, and Fork will return Null_Pid. + + 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); + + -- Fork a new process + + Descriptor.Pid := Fork; + + -- Are we now in the child (or, for Windows, still in the common + -- process). + + if Descriptor.Pid = Null_Pid then + + Command_With_Path := Locate_Exec_On_Path (Command); + + -- 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); + + Free (Command_With_Path); + end if; + + -- Did we have an error when spawning the child ? + + if Descriptor.Pid < Null_Pid then + null; + 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/get_targ.adb gcc-3.3/gcc/ada/get_targ.adb *** gcc-3.2.3/gcc/ada/get_targ.adb 2002-05-07 08:22:17.000000000 +0000 --- gcc-3.3/gcc/ada/get_targ.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/get_targ.ads gcc-3.3/gcc/ada/get_targ.ads *** gcc-3.2.3/gcc/ada/get_targ.ads 2002-05-04 03:28:06.000000000 +0000 --- gcc-3.3/gcc/ada/get_targ.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-except.ads gcc-3.3/gcc/ada/g-except.ads *** gcc-3.2.3/gcc/ada/g-except.ads 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-except.ads 2002-03-14 10:59:18.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-exctra.adb gcc-3.3/gcc/ada/g-exctra.adb *** gcc-3.2.3/gcc/ada/g-exctra.adb 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-exctra.adb 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-exctra.ads gcc-3.3/gcc/ada/g-exctra.ads *** gcc-3.2.3/gcc/ada/g-exctra.ads 2001-12-16 01:13:40.000000000 +0000 --- gcc-3.3/gcc/ada/g-exctra.ads 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2 $ -- -- -- Copyright (C) 2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-expect.adb gcc-3.3/gcc/ada/g-expect.adb *** gcc-3.2.3/gcc/ada/g-expect.adb 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-expect.adb 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- ! -- Copyright (C) 2000-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,13 ---- -- -- -- B o d y -- -- -- -- -- ! -- Copyright (C) 2000-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- -- *************** *** 32,50 **** -- -- ------------------------------------------------------------------------------ with GNAT.IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regpat; use GNAT.Regpat; ! with System; use System; ! with Unchecked_Conversion; with Unchecked_Deallocation; - with Ada.Calendar; use Ada.Calendar; package body GNAT.Expect is - function To_Pid is new - Unchecked_Conversion (OS_Lib.Process_Id, Process_Id); - type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; procedure Expect_Internal --- 31,47 ---- -- -- ------------------------------------------------------------------------------ + 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; procedure Expect_Internal *************** package body GNAT.Expect is *** 96,104 **** pragma Import (C, Create_Pipe, "__gnat_pipe"); function Read ! (Fd : File_Descriptor; ! A : System.Address; ! N : Integer) return Integer; pragma Import (C, Read, "read"); -- Read N bytes to address A from file referenced by FD. Returned value -- is count of bytes actually read, which can be less than N at EOF. --- 93,102 ---- pragma Import (C, Create_Pipe, "__gnat_pipe"); function Read ! (Fd : File_Descriptor; ! A : System.Address; ! N : Integer) ! return Integer; pragma Import (C, Read, "read"); -- Read N bytes to address A from file referenced by FD. Returned value -- is count of bytes actually read, which can be less than N at EOF. *************** package body GNAT.Expect is *** 108,116 **** -- Close a file given its file descriptor. function Write ! (Fd : File_Descriptor; ! A : System.Address; ! N : Integer) return Integer; pragma Import (C, Write, "write"); -- Read N bytes to address A from file referenced by FD. Returned value -- is count of bytes actually read, which can be less than N at EOF. --- 106,115 ---- -- Close a file given its file descriptor. function Write ! (Fd : File_Descriptor; ! A : System.Address; ! N : Integer) ! return Integer; pragma Import (C, Write, "write"); -- Read N bytes to address A from file referenced by FD. Returned value -- is count of bytes actually read, which can be less than N at EOF. *************** package body GNAT.Expect is *** 128,133 **** --- 127,136 ---- -- -- 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. + --------- -- "+" -- --------- *************** package body GNAT.Expect is *** 171,178 **** 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' --- 174,181 ---- 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' *************** package body GNAT.Expect is *** 218,227 **** -- Close -- ----------- ! procedure Close (Descriptor : in out Process_Descriptor) is ! Success : Boolean; ! Pid : OS_Lib.Process_Id; ! begin Close (Descriptor.Input_Fd); --- 221,230 ---- -- Close -- ----------- ! procedure Close ! (Descriptor : in out Process_Descriptor; ! Status : out Integer) ! is begin Close (Descriptor.Input_Fd); *************** package body GNAT.Expect is *** 231,244 **** Close (Descriptor.Output_Fd); ! -- ??? Should have timeouts for different signals, see ddd Kill (Descriptor.Pid, 9); GNAT.OS_Lib.Free (Descriptor.Buffer); Descriptor.Buffer_Size := 0; ! Wait_Process (Pid, Success); ! Descriptor.Pid := To_Pid (Pid); end Close; ------------ --- 234,252 ---- 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; ------------ *************** package body GNAT.Expect is *** 545,551 **** Num_Descriptors : Integer; Buffer_Size : Integer := 0; ! N : Integer; type File_Descriptor_Array is array (Descriptors'Range) of File_Descriptor; --- 553,559 ---- Num_Descriptors : Integer; Buffer_Size : Integer := 0; ! N : Integer; type File_Descriptor_Array is array (Descriptors'Range) of File_Descriptor; *************** package body GNAT.Expect is *** 849,927 **** Buffer_Size : Natural := 4096; Err_To_Out : Boolean := False) is ! function Fork return Process_Id; ! pragma Import (C, Fork, "__gnat_expect_fork"); ! -- Starts a new process if possible. ! -- See the Unix command fork for more information. On systems that ! -- don't support this capability (Windows...), this command does ! -- nothing, and Fork will return Null_Pid. ! ! 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); ! ! -- Fork a new process ! ! Descriptor.Pid := Fork; ! ! -- Are we now in the child (or, for Windows, still in the common ! -- process). ! ! if Descriptor.Pid = Null_Pid then ! ! Command_With_Path := Locate_Exec_On_Path (Command); ! ! -- 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); ! ! Free (Command_With_Path); ! end if; ! ! -- Did we have an error when spawning the child ? ! ! if Descriptor.Pid < Null_Pid then ! null; ! 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 -- --- 857,863 ---- Buffer_Size : Natural := 4096; Err_To_Out : Boolean := False) is ! separate; ------------------------- -- Reinitialize_Buffer -- *************** package body GNAT.Expect is *** 1061,1067 **** Cmd : in String; Args : in System.Address) is ! Input, Output, Error : File_Descriptor; begin -- Since Windows does not have a separate fork/exec, we need to --- 997,1007 ---- Cmd : in String; Args : in System.Address) is ! pragma Warnings (Off, Pid); ! ! Input : File_Descriptor; ! Output : File_Descriptor; ! Error : File_Descriptor; begin -- Since Windows does not have a separate fork/exec, we need to *************** package body GNAT.Expect is *** 1084,1090 **** Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); ! Portable_Execvp (Cmd & ASCII.Nul, Args); -- The following commands are not executed on Unix systems, and are -- only required for Windows systems. We are now in the parent process. --- 1024,1030 ---- Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); ! Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args); -- The following commands are not executed on Unix systems, and are -- only required for Windows systems. We are now in the parent process. *************** package body GNAT.Expect is *** 1108,1114 **** Err_To_Out : Boolean; Pipe1 : access Pipe_Type; Pipe2 : access Pipe_Type; ! Pipe3 : access Pipe_Type) is begin -- Create the pipes --- 1048,1055 ---- Err_To_Out : Boolean; Pipe1 : access Pipe_Type; Pipe2 : access Pipe_Type; ! Pipe3 : access Pipe_Type) ! is begin -- Create the pipes *************** package body GNAT.Expect is *** 1144,1149 **** --- 1085,1092 ---- Pipe2 : in out Pipe_Type; Pipe3 : in out Pipe_Type) is + pragma Warnings (Off, Pid); + begin Close (Pipe1.Input); Close (Pipe2.Output); *************** package body GNAT.Expect is *** 1159,1164 **** --- 1102,1110 ---- 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; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-expect.ads gcc-3.3/gcc/ada/g-expect.ads *** gcc-3.2.3/gcc/ada/g-expect.ads 2001-12-16 01:13:40.000000000 +0000 --- gcc-3.3/gcc/ada/g-expect.ads 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.2 $ -- -- ! -- Copyright (C) 2000-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,13 ---- -- -- -- S p e c -- -- -- -- -- ! -- Copyright (C) 2000-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- -- *************** *** 48,54 **** -- -- Usage example: -- ! -- Non_Blocking_Spawn (Fd, "ftp machine@domaine"); -- Timeout := 10000; -- 10 seconds -- Expect (Fd, Result, Regexp_Array'(+"\(user\)", +"\(passwd\)"), -- Timeout); --- 47,55 ---- -- -- Usage example: -- ! -- Non_Blocking_Spawn ! -- (Fd, "ftp", ! -- (1 => new String' ("machine@domaine"))); -- Timeout := 10000; -- 10 seconds -- Expect (Fd, Result, Regexp_Array'(+"\(user\)", +"\(passwd\)"), -- Timeout); *************** *** 78,89 **** -- processes, where you can give your own input and output filters every -- time characters are read from or written to the process. -- ! -- procedure My_Filter (Descriptor : Process_Descriptor; Str : String) is -- begin -- Put_Line (Str); -- end; -- ! -- Fd := Non_Blocking_Spawn ("tail -f a_file"); -- Add_Filter (Fd, My_Filter'Access, Output); -- Expect (Fd, Result, "", 0); -- wait forever -- --- 79,96 ---- -- processes, where you can give your own input and output filters every -- time characters are read from or written to the process. -- ! -- procedure My_Filter ! -- (Descriptor : Process_Descriptor'Class; ! -- Str : String; ! -- User_Data : System.Address) ! -- is -- begin -- Put_Line (Str); -- end; -- ! -- Non_Blocking_Spawn ! -- (Fd, "tail", ! -- (new String' ("-f"), new String' ("a_file"))); -- Add_Filter (Fd, My_Filter'Access, Output); -- Expect (Fd, Result, "", 0); -- wait forever -- *************** *** 98,105 **** -- existing output, it is recommended to do something like: -- -- Expect (Fd, Result, ".*", Timeout => 0); ! -- -- empty the buffer, by matching everything (after checking ! -- -- if there was any input). -- Send (Fd, "command"); -- Expect (Fd, Result, ".."); -- match only on the output of command -- --- 105,113 ---- -- existing output, it is recommended to do something like: -- -- Expect (Fd, Result, ".*", Timeout => 0); ! -- -- Empty the buffer, by matching everything (after checking ! -- -- if there was any input). ! -- -- Send (Fd, "command"); -- Expect (Fd, Result, ".."); -- match only on the output of command -- *************** package GNAT.Expect is *** 179,184 **** --- 187,198 ---- -- does the 'wait' command required to clean up the process table. -- This also frees the buffer associated with the process id. + procedure Close + (Descriptor : in out Process_Descriptor; + Status : out Integer); + -- Same as above, but also returns the exit status of the process, + -- as set for example by the procedure GNAT.OS_Lib.OS_Exit. + procedure Send_Signal (Descriptor : Process_Descriptor; Signal : Integer); *************** package GNAT.Expect is *** 510,529 **** -- valid process that died while Expect was executing. It is also raised -- when Expect receives an end-of-file. - ------------------------ - -- Internal functions -- - ------------------------ - - -- The following subprograms are provided so that it is easy to write - -- extensions to this package. However, clients should not use these - -- routines directly. - - procedure Portable_Execvp (Cmd : String; Args : System.Address); - -- Executes, in a portable way, the command Cmd (full path must be - -- specified), with the given Args. Note that the first element in Args - -- must be the executable name, and the last element must be a null - -- pointer - private type Filter_List_Elem; type Filter_List is access Filter_List_Elem; --- 524,529 ---- *************** private *** 568,574 **** -- newly created process. type Process_Descriptor is tagged record ! Pid : Process_Id := Invalid_Pid; Input_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; Output_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; Error_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; --- 568,574 ---- -- newly created process. type Process_Descriptor is tagged record ! Pid : aliased Process_Id := Invalid_Pid; Input_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; Output_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; Error_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; *************** private *** 584,589 **** --- 584,601 ---- Last_Match_End : Natural := 0; end record; + -- The following subprogram is provided for use in the body, and also + -- possibly in future child units providing extensions to this package. + + procedure Portable_Execvp + (Pid : access Process_Id; + Cmd : String; + Args : System.Address); pragma Import (C, Portable_Execvp, "__gnat_expect_portable_execvp"); + -- Executes, in a portable way, the command Cmd (full path must be + -- specified), with the given Args. Args must be an array of string + -- pointers. Note that the first element in Args must be the executable + -- name, and the last element must be a null pointer. The returned value + -- in Pid is the process ID, or zero if not supported on the platform. end GNAT.Expect; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-flocon.ads gcc-3.3/gcc/ada/g-flocon.ads *** gcc-3.2.3/gcc/ada/g-flocon.ads 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-flocon.ads 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-hesora.adb gcc-3.3/gcc/ada/g-hesora.adb *** gcc-3.2.3/gcc/ada/g-hesora.adb 2002-05-07 08:22:15.000000000 +0000 --- gcc-3.3/gcc/ada/g-hesora.adb 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1995-1999 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-hesora.ads gcc-3.3/gcc/ada/g-hesora.ads *** gcc-3.2.3/gcc/ada/g-hesora.ads 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-hesora.ads 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-hesorg.adb gcc-3.3/gcc/ada/g-hesorg.adb *** gcc-3.2.3/gcc/ada/g-hesorg.adb 2002-05-07 08:22:16.000000000 +0000 --- gcc-3.3/gcc/ada/g-hesorg.adb 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1995-1999 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-hesorg.ads gcc-3.3/gcc/ada/g-hesorg.ads *** gcc-3.2.3/gcc/ada/g-hesorg.ads 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-hesorg.ads 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-htable.adb gcc-3.3/gcc/ada/g-htable.adb *** gcc-3.2.3/gcc/ada/g-htable.adb 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-htable.adb 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-1999 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-htable.ads gcc-3.3/gcc/ada/g-htable.ads *** gcc-3.2.3/gcc/ada/g-htable.ads 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-htable.ads 2002-03-14 10:59:19.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gigi.h gcc-3.3/gcc/ada/gigi.h *** gcc-3.2.3/gcc/ada/gigi.h 2002-05-04 03:28:06.000000000 +0000 --- gcc-3.3/gcc/ada/gigi.h 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** * * * C Header File * * * - * $Revision: 1.3.10.1 $ * * ! * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * --- 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- * *************** extern void update_setjmp_buf PARAMS ((t *** 60,77 **** default. */ extern int default_pass_by_ref PARAMS ((tree)); ! /* GNU_TYPE is the type of a subprogram parameter. Determine from the type if ! it should be passed by reference. */ extern int must_pass_by_ref PARAMS ((tree)); ! /* Elaboration routines for the front end */ ! extern void elab_all_gnat PARAMS ((void)); ! /* Emit a label UNITNAME_LABEL and specify that it is part of source ! file FILENAME. If this is being written for SGI's Workshop ! debugger, and we are writing Dwarf2 debugging information, add ! additional debug info. */ ! extern void emit_unit_label PARAMS ((char *, char *)); /* Initialize DUMMY_NODE_TABLE. */ extern void init_dummy_type PARAMS ((void)); --- 59,73 ---- default. */ extern int default_pass_by_ref PARAMS ((tree)); ! /* GNU_TYPE is the type of a subprogram parameter. Determine from the type ! if it should be passed by reference. */ extern int must_pass_by_ref PARAMS ((tree)); ! /* This function returns the version of GCC being used. Here it's GCC 3. */ ! extern int gcc_version PARAMS ((void)); ! /* Elaboration routines for the front end. */ ! extern void elab_all_gnat PARAMS ((void)); /* Initialize DUMMY_NODE_TABLE. */ extern void init_dummy_type PARAMS ((void)); *************** extern const char *ref_filename; *** 163,173 **** /* List of TREE_LIST nodes representing a block stack. TREE_VALUE of each gives the variable used for the setjmp buffer in the current block, if any. */ ! extern tree gnu_block_stack; ! ! /* For most front-ends, this is the parser for the language. For us, we ! process the GNAT tree. */ ! extern int yyparse PARAMS ((void)); /* This is the main program of the back-end. It sets up all the table structures and then generates code. */ --- 159,165 ---- /* List of TREE_LIST nodes representing a block stack. TREE_VALUE of each gives the variable used for the setjmp buffer in the current block, if any. */ ! extern GTY(()) tree gnu_block_stack; /* This is the main program of the back-end. It sets up all the table structures and then generates code. */ *************** extern void post_error_ne_tree_2 PARAMS *** 235,243 **** /* Set the node for a second '&' in the error message. */ extern void set_second_error_entity PARAMS ((Entity_Id)); ! /* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially ! since it doesn't make any sense to put them in a SAVE_EXPR. */ ! extern tree make_save_expr PARAMS ((tree)); /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node as the relevant node that provides the location info for the error. --- 227,234 ---- /* Set the node for a second '&' in the error message. */ extern void set_second_error_entity PARAMS ((Entity_Id)); ! /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */ ! extern tree protect_multiple_eval PARAMS ((tree)); /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node as the relevant node that provides the location info for the error. *************** enum standard_datatypes *** 355,366 **** ADT_setjmp_decl, ADT_longjmp_decl, ADT_raise_nodefer_decl, - ADT_raise_constraint_error_decl, - ADT_raise_program_error_decl, - ADT_raise_storage_error_decl, ADT_LAST}; ! extern tree gnat_std_decls[(int) ADT_LAST]; #define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type] #define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl] --- 346,355 ---- ADT_setjmp_decl, ADT_longjmp_decl, ADT_raise_nodefer_decl, ADT_LAST}; ! extern GTY(()) tree gnat_std_decls[(int) ADT_LAST]; ! extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; #define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type] #define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl] *************** extern tree gnat_std_decls[(int) ADT_LAS *** 378,389 **** #define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl] #define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl] #define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl] - #define raise_constraint_error_decl \ - gnat_std_decls[(int) ADT_raise_constraint_error_decl] - #define raise_program_error_decl \ - gnat_std_decls[(int) ADT_raise_program_error_decl] - #define raise_storage_error_decl \ - gnat_std_decls[(int) ADT_raise_storage_error_decl] /* Routines expected by the gcc back-end. They must have exactly the same prototype and names as below. */ --- 367,372 ---- *************** extern tree pushdecl PARAMS ((tree)); *** 435,470 **** in the gcc back-end and initialize the global binding level. */ extern void gnat_init_decl_processing PARAMS ((void)); extern void init_gigi_decls PARAMS ((tree, tree)); /* Return an integer type with the number of bits of precision given by PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise it is a signed type. */ ! extern tree type_for_size PARAMS ((unsigned, int)); /* Return a data type that has machine mode MODE. UNSIGNEDP selects an unsigned type; otherwise a signed type is returned. */ ! extern tree type_for_mode PARAMS ((enum machine_mode, int)); /* Return the unsigned version of a TYPE_NODE, a scalar type. */ ! extern tree unsigned_type PARAMS ((tree)); /* Return the signed version of a TYPE_NODE, a scalar type. */ ! extern tree signed_type PARAMS ((tree)); /* Return a type the same as TYPE except unsigned or signed according to UNSIGNEDP. */ ! extern tree signed_or_unsigned_type PARAMS ((int, tree)); ! ! /* This routine is called in tree.c to print an error message for invalid use ! of an incomplete type. */ ! extern void incomplete_type_error PARAMS ((tree, tree)); /* This function is called indirectly from toplev.c to handle incomplete declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise, compile_file in toplev.c makes an indirect call through the function pointer incomplete_decl_finalize_hook which is initialized to this routine in init_decl_processing. */ ! extern void finish_incomplete_decl PARAMS ((tree)); /* Create an expression whose value is that of EXPR, converted to type TYPE. The TREE_TYPE of the value --- 418,450 ---- in the gcc back-end and initialize the global binding level. */ extern void gnat_init_decl_processing PARAMS ((void)); extern void init_gigi_decls PARAMS ((tree, tree)); + extern void gnat_init_gcc_eh PARAMS ((void)); /* Return an integer type with the number of bits of precision given by PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise it is a signed type. */ ! extern tree gnat_type_for_size PARAMS ((unsigned, int)); /* Return a data type that has machine mode MODE. UNSIGNEDP selects an unsigned type; otherwise a signed type is returned. */ ! extern tree gnat_type_for_mode PARAMS ((enum machine_mode, int)); /* Return the unsigned version of a TYPE_NODE, a scalar type. */ ! extern tree gnat_unsigned_type PARAMS ((tree)); /* Return the signed version of a TYPE_NODE, a scalar type. */ ! extern tree gnat_signed_type PARAMS ((tree)); /* Return a type the same as TYPE except unsigned or signed according to UNSIGNEDP. */ ! extern tree gnat_signed_or_unsigned_type PARAMS ((int, tree)); /* This function is called indirectly from toplev.c to handle incomplete declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise, compile_file in toplev.c makes an indirect call through the function pointer incomplete_decl_finalize_hook which is initialized to this routine in init_decl_processing. */ ! extern void gnat_finish_incomplete_decl PARAMS ((tree)); /* Create an expression whose value is that of EXPR, converted to type TYPE. The TREE_TYPE of the value *************** extern void update_pointer_to PARAMS (( *** 645,652 **** extern tree max_size PARAMS ((tree, int)); /* Remove all conversions that are done in EXP. This includes converting ! from a padded type or converting to a left-justified modular type. */ ! extern tree remove_conversions PARAMS ((tree)); /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, --- 625,634 ---- extern tree max_size PARAMS ((tree, int)); /* Remove all conversions that are done in EXP. This includes converting ! from a padded type or to a left-justified modular type. If TRUE_ADDRESS ! is nonzero, always return the address of the containing object even if ! the address is not bit-aligned. */ ! extern tree remove_conversions PARAMS ((tree, int)); /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, *************** extern tree unchecked_convert PARAMS (( *** 668,674 **** The resulting type should always be the same as the input type. This function is simpler than the corresponding C version since the only possible operands will be things of Boolean type. */ ! extern tree truthvalue_conversion PARAMS((tree)); /* Return the base type of TYPE. */ extern tree get_base_type PARAMS((tree)); --- 650,656 ---- The resulting type should always be the same as the input type. This function is simpler than the corresponding C version since the only possible operands will be things of Boolean type. */ ! extern tree gnat_truthvalue_conversion PARAMS((tree)); /* Return the base type of TYPE. */ extern tree get_base_type PARAMS((tree)); *************** extern tree build_call_2_expr PARAMS((tr *** 705,713 **** /* Likewise to call FUNDECL with no arguments. */ extern tree build_call_0_expr PARAMS((tree)); ! /* Call a function FCN that raises an exception and pass the line ! number and file name, if requested. */ ! extern tree build_call_raise PARAMS((tree)); /* Return a CONSTRUCTOR of TYPE whose list is LIST. */ extern tree build_constructor PARAMS((tree, tree)); --- 687,695 ---- /* Likewise to call FUNDECL with no arguments. */ extern tree build_call_0_expr PARAMS((tree)); ! /* Call a function that raises an exception and pass the line number and file ! name, if requested. MSG says which exception function to call. */ ! extern tree build_call_raise PARAMS((int)); /* Return a CONSTRUCTOR of TYPE whose list is LIST. */ extern tree build_constructor PARAMS((tree, tree)); *************** extern tree build_allocator PARAMS((tree *** 741,748 **** extern tree fill_vms_descriptor PARAMS((tree, Entity_Id)); /* Indicate that we need to make the address of EXPR_NODE and it therefore ! should not be allocated in a register. Return 1 if successful. */ ! extern int mark_addressable PARAMS((tree)); /* These functions return the basic data type sizes and related parameters about the target machine. */ --- 723,730 ---- extern tree fill_vms_descriptor PARAMS((tree, Entity_Id)); /* Indicate that we need to make the address of EXPR_NODE and it therefore ! should not be allocated in a register. Return true if successful. */ ! extern bool gnat_mark_addressable PARAMS((tree)); /* These functions return the basic data type sizes and related parameters about the target machine. */ diff -Nrc3pad gcc-3.2.3/gcc/ada/g-io.adb gcc-3.3/gcc/ada/g-io.adb *** gcc-3.2.3/gcc/ada/g-io.adb 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-io.adb 2002-03-14 10:59:20.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-io.ads gcc-3.3/gcc/ada/g-io.ads *** gcc-3.2.3/gcc/ada/g-io.ads 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-io.ads 2002-03-14 10:59:20.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- *************** *** 36,45 **** -- A simple text I/O package that can be used for simple I/O functions in -- user programs as required. This package is also preelaborated, unlike ! -- Text_Io, and can thus be with'ed by preelaborated library units. -- Note that Data_Error is not raised by these subprograms for bad data. ! -- If such checks are needed then the regular Text_IO package such be used. package GNAT.IO is pragma Preelaborate (IO); --- 35,44 ---- -- A simple text I/O package that can be used for simple I/O functions in -- user programs as required. This package is also preelaborated, unlike ! -- Text_IO, and can thus be with'ed by preelaborated library units. -- Note that Data_Error is not raised by these subprograms for bad data. ! -- If such checks are needed then the regular Text_IO package must be used. package GNAT.IO is pragma Preelaborate (IO); diff -Nrc3pad gcc-3.2.3/gcc/ada/g-io_aux.adb gcc-3.3/gcc/ada/g-io_aux.adb *** gcc-3.2.3/gcc/ada/g-io_aux.adb 2001-10-02 14:15:31.000000000 +0000 --- gcc-3.3/gcc/ada/g-io_aux.adb 2002-03-14 10:59:21.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1 $ -- -- ! -- Copyright (C) 1995-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,13 ---- -- -- -- B o d y -- -- -- -- -- ! -- Copyright (C) 1995-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- -- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-io_aux.ads gcc-3.3/gcc/ada/g-io_aux.ads *** gcc-3.2.3/gcc/ada/g-io_aux.ads 2002-05-07 08:22:16.000000000 +0000 --- gcc-3.3/gcc/ada/g-io_aux.ads 2002-03-14 10:59:21.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1995-1998 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,13 ---- -- -- -- S p e c -- -- -- -- -- ! -- Copyright (C) 1995-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- -- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-locfil.adb gcc-3.3/gcc/ada/g-locfil.adb *** gcc-3.2.3/gcc/ada/g-locfil.adb 2002-05-04 03:28:05.000000000 +0000 --- gcc-3.3/gcc/ada/g-locfil.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** package body GNAT.Lock_Files is *** 44,51 **** --------------- procedure Lock_File ! (Directory : String; ! Lock_File_Name : String; Wait : Duration := 1.0; Retries : Natural := Natural'Last) is --- 43,50 ---- --------------- procedure Lock_File ! (Directory : Path_Name; ! Lock_File_Name : Path_Name; Wait : Duration := 1.0; Retries : Natural := Natural'Last) is *************** package body GNAT.Lock_Files is *** 56,68 **** --- 55,80 ---- pragma Import (C, Try_Lock, "__gnat_try_lock"); begin + -- If a directory separator was provided, just remove the one we have + -- added above. + + if Directory (Directory'Last) = Dir_Separator + or else Directory (Directory'Last) = '/' + then + Dir (Dir'Last - 1) := ASCII.Nul; + end if; + + -- Try to lock the file Retries times + for I in 0 .. Retries loop if Try_Lock (Dir'Address, File'Address) = 1 then return; end if; + exit when I = Retries; delay Wait; end loop; + raise Lock_Error; end Lock_File; *************** package body GNAT.Lock_Files is *** 71,83 **** --------------- procedure Lock_File ! (Lock_File_Name : String; Wait : Duration := 1.0; Retries : Natural := Natural'Last) is begin for J in reverse Lock_File_Name'Range loop ! if Lock_File_Name (J) = Dir_Separator then Lock_File (Lock_File_Name (Lock_File_Name'First .. J - 1), Lock_File_Name (J + 1 .. Lock_File_Name'Last), --- 83,97 ---- --------------- procedure Lock_File ! (Lock_File_Name : Path_Name; Wait : Duration := 1.0; Retries : Natural := Natural'Last) is begin for J in reverse Lock_File_Name'Range loop ! if Lock_File_Name (J) = Dir_Separator ! or else Lock_File_Name (J) = '/' ! then Lock_File (Lock_File_Name (Lock_File_Name'First .. J - 1), Lock_File_Name (J + 1 .. Lock_File_Name'Last), *************** package body GNAT.Lock_Files is *** 94,100 **** -- Unlock_File -- ----------------- ! procedure Unlock_File (Lock_File_Name : String) is S : aliased String := Lock_File_Name & ASCII.NUL; procedure unlink (A : System.Address); --- 108,114 ---- -- Unlock_File -- ----------------- ! procedure Unlock_File (Lock_File_Name : Path_Name) is S : aliased String := Lock_File_Name & ASCII.NUL; procedure unlink (A : System.Address); *************** package body GNAT.Lock_Files is *** 108,116 **** -- Unlock_File -- ----------------- ! procedure Unlock_File (Directory : String; Lock_File_Name : String) is begin ! Unlock_File (Directory & Dir_Separator & Lock_File_Name); end Unlock_File; end GNAT.Lock_Files; --- 122,136 ---- -- Unlock_File -- ----------------- ! procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name) is begin ! if Directory (Directory'Last) = Dir_Separator ! or else Directory (Directory'Last) = '/' ! then ! Unlock_File (Directory & Lock_File_Name); ! else ! Unlock_File (Directory & Dir_Separator & Lock_File_Name); ! end if; end Unlock_File; end GNAT.Lock_Files; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-locfil.ads gcc-3.3/gcc/ada/g-locfil.ads *** gcc-3.2.3/gcc/ada/g-locfil.ads 2001-10-02 14:15:32.000000000 +0000 --- gcc-3.3/gcc/ada/g-locfil.ads 2002-03-14 10:59:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1995-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- *************** *** 32,39 **** -- -- ------------------------------------------------------------------------------ ! -- This package contains the necessary routines for using files for the ! -- purpose of providing realiable system wide locking capability. package GNAT.Lock_Files is pragma Preelaborate; --- 31,38 ---- -- -- ------------------------------------------------------------------------------ ! -- This package contains the necessary routines for using files for the ! -- purpose of providing realiable system wide locking capability. package GNAT.Lock_Files is pragma Preelaborate; *************** pragma Preelaborate; *** 41,67 **** Lock_Error : exception; -- Exception raised if file cannot be locked procedure Lock_File ! (Directory : String; ! Lock_File_Name : String; Wait : Duration := 1.0; Retries : Natural := Natural'Last); -- Create a lock file Lock_File_Name in directory Directory. If the file -- cannot be locked because someone already owns the lock, this procedure -- waits Wait seconds and retries at most Retries times. If the file -- still cannot be locked, Lock_Error is raised. The default is to try ! -- every second, almost forever (Natural'Last times). procedure Lock_File ! (Lock_File_Name : String; Wait : Duration := 1.0; Retries : Natural := Natural'Last); -- See above. The full lock file path is given as one string. ! procedure Unlock_File (Directory : String; Lock_File_Name : String); ! -- Unlock a file ! procedure Unlock_File (Lock_File_Name : String); -- Unlock a file whose full path is given in Lock_File_Name end GNAT.Lock_Files; --- 40,74 ---- Lock_Error : exception; -- Exception raised if file cannot be locked + subtype Path_Name is String; + -- Pathname is used by all services provided in this unit to specified + -- directory name and file name. On DOS based systems both directory + -- separators are handled (i.e. slash and backslash). + procedure Lock_File ! (Directory : Path_Name; ! Lock_File_Name : Path_Name; Wait : Duration := 1.0; Retries : Natural := Natural'Last); -- Create a lock file Lock_File_Name in directory Directory. If the file -- cannot be locked because someone already owns the lock, this procedure -- waits Wait seconds and retries at most Retries times. If the file -- still cannot be locked, Lock_Error is raised. The default is to try ! -- every second, almost forever (Natural'Last times). The full path of ! -- the file is constructed by concatenating Directory and Lock_File_Name. ! -- Directory can optionally terminate with a directory separator. procedure Lock_File ! (Lock_File_Name : Path_Name; Wait : Duration := 1.0; Retries : Natural := Natural'Last); -- See above. The full lock file path is given as one string. ! procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name); ! -- Unlock a file. Directory can optionally terminate with a directory ! -- separator. ! procedure Unlock_File (Lock_File_Name : Path_Name); -- Unlock a file whose full path is given in Lock_File_Name end GNAT.Lock_Files; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-md5.adb gcc-3.3/gcc/ada/g-md5.adb *** gcc-3.2.3/gcc/ada/g-md5.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/g-md5.adb 2002-03-14 10:59:21.000000000 +0000 *************** *** 0 **** --- 1,550 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT LIBRARY COMPONENTS -- + -- -- + -- G N A T . M D 5 -- + -- -- + -- B o d y -- + -- -- + -- -- + -- Copyright (C) 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- + -- -- + ------------------------------------------------------------------------------ + + with Ada.Unchecked_Conversion; + + package body GNAT.MD5 is + + use Interfaces; + + Padding : constant String := + (1 => Character'Val (16#80#), 2 .. 64 => ASCII.NUL); + + Hex_Digit : constant array (Unsigned_32 range 0 .. 15) of Character := + ('0', '1', '2', '3', '4', '5', '6', '7', + '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); + -- Look-up table for each hex digit of the Message-Digest. + -- Used by function Digest (Context). + + -- The sixten values used to rotate the context words. + -- Four for each rounds. Used in procedure Transform. + + -- Round 1 + + S11 : constant := 7; + S12 : constant := 12; + S13 : constant := 17; + S14 : constant := 22; + + -- Round 2 + + S21 : constant := 5; + S22 : constant := 9; + S23 : constant := 14; + S24 : constant := 20; + + -- Round 3 + + S31 : constant := 4; + S32 : constant := 11; + S33 : constant := 16; + S34 : constant := 23; + + -- Round 4 + + S41 : constant := 6; + S42 : constant := 10; + S43 : constant := 15; + S44 : constant := 21; + + type Sixteen_Words is array (Natural range 0 .. 15) + of Interfaces.Unsigned_32; + -- Sixteen 32-bit words, converted from block of 64 characters. + -- Used in procedure Decode and Transform. + + procedure Decode + (Block : String; + X : out Sixteen_Words); + -- Convert a String of 64 characters into 16 32-bit numbers + + -- The following functions (F, FF, G, GG, H, HH, I and II) are the + -- equivalent of the macros of the same name in the example + -- C implementation in the annex of RFC 1321. + + function F (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (F); + + procedure FF + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (FF); + + function G (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (G); + + procedure GG + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (GG); + + function H (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (H); + + procedure HH + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (HH); + + function I (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (I); + + procedure II + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (II); + + procedure Transform + (C : in out Context; + Block : String); + -- Process one block of 64 characters. + + ------------ + -- Decode -- + ------------ + + procedure Decode + (Block : String; + X : out Sixteen_Words) + is + Cur : Positive := Block'First; + + begin + pragma Assert (Block'Length = 64); + + for Index in X'Range loop + X (Index) := + Unsigned_32 (Character'Pos (Block (Cur))) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 8) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 16) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 3))), 24); + Cur := Cur + 4; + end loop; + end Decode; + + ------------ + -- Digest -- + ------------ + + function Digest (C : Context) return Message_Digest is + Result : Message_Digest; + + Cur : Natural := 1; + -- Index in Result where the next character will be placed. + + procedure Convert (X : Unsigned_32); + -- Put the contribution of one of the four words (A, B, C, D) of the + -- Context in Result. Increments Cur. + + ------------- + -- Convert -- + ------------- + + procedure Convert (X : Unsigned_32) is + Y : Unsigned_32 := X; + + begin + for J in 1 .. 4 loop + Result (Cur + 1) := Hex_Digit (Y and Unsigned_32'(16#0F#)); + Y := Shift_Right (Y, 4); + Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#)); + Y := Shift_Right (Y, 4); + Cur := Cur + 2; + end loop; + end Convert; + + -- Start of processing for Digest + + begin + Convert (C.A); + Convert (C.B); + Convert (C.C); + Convert (C.D); + return Result; + end Digest; + + function Digest (S : String) return Message_Digest is + C : Context; + + begin + Update (C, S); + return Digest (C); + end Digest; + + function Digest + (A : Ada.Streams.Stream_Element_Array) + return Message_Digest + is + C : Context; + + begin + Update (C, A); + return Digest (C); + end Digest; + + ------- + -- F -- + ------- + + function F (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return (X and Y) or ((not X) and Z); + end F; + + -------- + -- FF -- + -------- + + procedure FF + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + F (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end FF; + + ------- + -- G -- + ------- + + function G (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return (X and Z) or (Y and (not Z)); + end G; + + -------- + -- GG -- + -------- + + procedure GG + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + G (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end GG; + + ------- + -- H -- + ------- + + function H (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return X xor Y xor Z; + end H; + + -------- + -- HH -- + -------- + + procedure HH + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + H (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end HH; + + ------- + -- I -- + ------- + + function I (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return Y xor (X or (not Z)); + end I; + + -------- + -- II -- + -------- + + procedure II + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + I (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end II; + + --------------- + -- Transform -- + --------------- + + procedure Transform + (C : in out Context; + Block : String) + is + X : Sixteen_Words; + + AA : Unsigned_32 := C.A; + BB : Unsigned_32 := C.B; + CC : Unsigned_32 := C.C; + DD : Unsigned_32 := C.D; + + begin + pragma Assert (Block'Length = 64); + + Decode (Block, X); + + -- Round 1 + + FF (AA, BB, CC, DD, X (00), 16#D76aa478#, S11); -- 1 + FF (DD, AA, BB, CC, X (01), 16#E8c7b756#, S12); -- 2 + FF (CC, DD, AA, BB, X (02), 16#242070db#, S13); -- 3 + FF (BB, CC, DD, AA, X (03), 16#C1bdceee#, S14); -- 4 + + FF (AA, BB, CC, DD, X (04), 16#f57c0faf#, S11); -- 5 + FF (DD, AA, BB, CC, X (05), 16#4787c62a#, S12); -- 6 + FF (CC, DD, AA, BB, X (06), 16#a8304613#, S13); -- 7 + FF (BB, CC, DD, AA, X (07), 16#fd469501#, S14); -- 8 + + FF (AA, BB, CC, DD, X (08), 16#698098d8#, S11); -- 9 + FF (DD, AA, BB, CC, X (09), 16#8b44f7af#, S12); -- 10 + FF (CC, DD, AA, BB, X (10), 16#ffff5bb1#, S13); -- 11 + FF (BB, CC, DD, AA, X (11), 16#895cd7be#, S14); -- 12 + + FF (AA, BB, CC, DD, X (12), 16#6b901122#, S11); -- 13 + FF (DD, AA, BB, CC, X (13), 16#fd987193#, S12); -- 14 + FF (CC, DD, AA, BB, X (14), 16#a679438e#, S13); -- 15 + FF (BB, CC, DD, AA, X (15), 16#49b40821#, S14); -- 16 + + -- Round 2 + + GG (AA, BB, CC, DD, X (01), 16#f61e2562#, S21); -- 17 + GG (DD, AA, BB, CC, X (06), 16#c040b340#, S22); -- 18 + GG (CC, DD, AA, BB, X (11), 16#265e5a51#, S23); -- 19 + GG (BB, CC, DD, AA, X (00), 16#e9b6c7aa#, S24); -- 20 + + GG (AA, BB, CC, DD, X (05), 16#d62f105d#, S21); -- 21 + GG (DD, AA, BB, CC, X (10), 16#02441453#, S22); -- 22 + GG (CC, DD, AA, BB, X (15), 16#d8a1e681#, S23); -- 23 + GG (BB, CC, DD, AA, X (04), 16#e7d3fbc8#, S24); -- 24 + + GG (AA, BB, CC, DD, X (09), 16#21e1cde6#, S21); -- 25 + GG (DD, AA, BB, CC, X (14), 16#c33707d6#, S22); -- 26 + GG (CC, DD, AA, BB, X (03), 16#f4d50d87#, S23); -- 27 + GG (BB, CC, DD, AA, X (08), 16#455a14ed#, S24); -- 28 + + GG (AA, BB, CC, DD, X (13), 16#a9e3e905#, S21); -- 29 + GG (DD, AA, BB, CC, X (02), 16#fcefa3f8#, S22); -- 30 + GG (CC, DD, AA, BB, X (07), 16#676f02d9#, S23); -- 31 + GG (BB, CC, DD, AA, X (12), 16#8d2a4c8a#, S24); -- 32 + + -- Round 3 + + HH (AA, BB, CC, DD, X (05), 16#fffa3942#, S31); -- 33 + HH (DD, AA, BB, CC, X (08), 16#8771f681#, S32); -- 34 + HH (CC, DD, AA, BB, X (11), 16#6d9d6122#, S33); -- 35 + HH (BB, CC, DD, AA, X (14), 16#fde5380c#, S34); -- 36 + + HH (AA, BB, CC, DD, X (01), 16#a4beea44#, S31); -- 37 + HH (DD, AA, BB, CC, X (04), 16#4bdecfa9#, S32); -- 38 + HH (CC, DD, AA, BB, X (07), 16#f6bb4b60#, S33); -- 39 + HH (BB, CC, DD, AA, X (10), 16#bebfbc70#, S34); -- 40 + + HH (AA, BB, CC, DD, X (13), 16#289b7ec6#, S31); -- 41 + HH (DD, AA, BB, CC, X (00), 16#eaa127fa#, S32); -- 42 + HH (CC, DD, AA, BB, X (03), 16#d4ef3085#, S33); -- 43 + HH (BB, CC, DD, AA, X (06), 16#04881d05#, S34); -- 44 + + HH (AA, BB, CC, DD, X (09), 16#d9d4d039#, S31); -- 45 + HH (DD, AA, BB, CC, X (12), 16#e6db99e5#, S32); -- 46 + HH (CC, DD, AA, BB, X (15), 16#1fa27cf8#, S33); -- 47 + HH (BB, CC, DD, AA, X (02), 16#c4ac5665#, S34); -- 48 + + -- Round 4 + + II (AA, BB, CC, DD, X (00), 16#f4292244#, S41); -- 49 + II (DD, AA, BB, CC, X (07), 16#432aff97#, S42); -- 50 + II (CC, DD, AA, BB, X (14), 16#ab9423a7#, S43); -- 51 + II (BB, CC, DD, AA, X (05), 16#fc93a039#, S44); -- 52 + + II (AA, BB, CC, DD, X (12), 16#655b59c3#, S41); -- 53 + II (DD, AA, BB, CC, X (03), 16#8f0ccc92#, S42); -- 54 + II (CC, DD, AA, BB, X (10), 16#ffeff47d#, S43); -- 55 + II (BB, CC, DD, AA, X (01), 16#85845dd1#, S44); -- 56 + + II (AA, BB, CC, DD, X (08), 16#6fa87e4f#, S41); -- 57 + II (DD, AA, BB, CC, X (15), 16#fe2ce6e0#, S42); -- 58 + II (CC, DD, AA, BB, X (06), 16#a3014314#, S43); -- 59 + II (BB, CC, DD, AA, X (13), 16#4e0811a1#, S44); -- 60 + + II (AA, BB, CC, DD, X (04), 16#f7537e82#, S41); -- 61 + II (DD, AA, BB, CC, X (11), 16#bd3af235#, S42); -- 62 + II (CC, DD, AA, BB, X (02), 16#2ad7d2bb#, S43); -- 63 + II (BB, CC, DD, AA, X (09), 16#eb86d391#, S44); -- 64 + + C.A := C.A + AA; + C.B := C.B + BB; + C.C := C.C + CC; + C.D := C.D + DD; + + end Transform; + + ------------ + -- Update -- + ------------ + + procedure Update + (C : in out Context; + Input : String) + is + Cur : Positive := Input'First; + Last_Block : String (1 .. 64); + + begin + while Cur + 63 <= Input'Last loop + Transform (C, Input (Cur .. Cur + 63)); + Cur := Cur + 64; + end loop; + + Last_Block (1 .. Input'Last - Cur + 1) := Input (Cur .. Input'Last); + + if Input'Last - Cur + 1 > 56 then + Cur := Input'Last - Cur + 2; + Last_Block (Cur .. 64) := Padding (1 .. 64 - Cur + 1); + Transform (C, Last_Block); + Last_Block := (others => ASCII.NUL); + + else + Cur := Input'Last - Cur + 2; + Last_Block (Cur .. 56) := Padding (1 .. 56 - Cur + 1); + end if; + + -- Add the input length as 8 characters + + Last_Block (57 .. 64) := (others => ASCII.NUL); + + declare + L : Unsigned_64 := Unsigned_64 (Input'Length) * 8; + + begin + Cur := 57; + while L > 0 loop + Last_Block (Cur) := Character'Val (L and 16#Ff#); + L := Shift_Right (L, 8); + Cur := Cur + 1; + end loop; + end; + + Transform (C, Last_Block); + end Update; + + procedure Update + (C : in out Context; + Input : Ada.Streams.Stream_Element_Array) + is + subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range); + subtype Stream_String is + String (1 + Integer (Input'First) .. 1 + Integer (Input'Last)); + + function To_String is new Ada.Unchecked_Conversion + (Stream_Array, Stream_String); + + String_Input : constant String := To_String (Input); + begin + Update (C, String_Input); + end Update; + + ----------------- + -- Wide_Digest -- + ----------------- + + function Wide_Digest (W : Wide_String) return Message_Digest is + C : Context; + + begin + Wide_Update (C, W); + return Digest (C); + end Wide_Digest; + + ----------------- + -- Wide_Update -- + ----------------- + + procedure Wide_Update + (C : in out Context; + Input : Wide_String) + is + + String_Input : String (1 .. 2 * Input'Length); + Cur : Positive := 1; + + begin + for Index in Input'Range loop + String_Input (Cur) := + Character'Val + (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#); + Cur := Cur + 1; + String_Input (Cur) := + Character'Val + (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8) + and 16#FF#); + Cur := Cur + 1; + end loop; + + Update (C, String_Input); + end Wide_Update; + + end GNAT.MD5; diff -Nrc3pad gcc-3.2.3/gcc/ada/g-md5.ads gcc-3.3/gcc/ada/g-md5.ads *** gcc-3.2.3/gcc/ada/g-md5.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/g-md5.ads 2002-03-14 10:59:21.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT LIBRARY COMPONENTS -- + -- -- + -- G N A T . M D 5 -- + -- -- + -- S p e c -- + -- -- + -- -- + -- Copyright (C) 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- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- + -- -- + ------------------------------------------------------------------------------ + -- + -- This package implements the MD5 Message-Digest Algorithm as described in + -- RFC 1321. The complete text of RFC 1321 can be found at: + -- + -- http://www.ietf.org/rfc/rfc1321.txt + -- + -- The implementation is derived from the RSA Data Secutity, Inc. MD5 + -- Message-Digest Algorithm, as described in RFC 1321. + + with Ada.Streams; + with Interfaces; + + package GNAT.MD5 is + + type Context is private; + -- This type is the four-word (16 byte) MD buffer, as described in + -- RFC 1321 (3.3). It initial value is Initial_Context below. + + Initial_Context : constant Context; + -- Initial value of a Context object. May be used to reinitialize + -- a Context value by simple assignment of this value to the object. + + procedure Update + (C : in out Context; + Input : String); + procedure Wide_Update + (C : in out Context; + Input : Wide_String); + procedure Update + (C : in out Context; + Input : Ada.Streams.Stream_Element_Array); + -- Modify the Context C. If C has the initial value Initial_Context, + -- then, after a call to one of these procedures, Digest (C) will return + -- the Message-Digest of Input. + -- + -- These procedures may be called successively with the same context and + -- different inputs. However, several successive calls will not produce + -- the same final context as a call with the concatenation of the inputs. + + subtype Message_Digest is String (1 .. 32); + -- The string type returned by function Digest. + + function Digest (C : Context) return Message_Digest; + -- Extracts the Message-Digest from a context. This function should be + -- used after one or several calls to Update. + + function Digest (S : String) return Message_Digest; + function Wide_Digest (W : Wide_String) return Message_Digest; + function Digest + (A : Ada.Streams.Stream_Element_Array) + return Message_Digest; + -- These functions are equivalent to the corresponding Update (or + -- Wide_Update) on a default initialized Context, followed by Digest + -- on the resulting Context. + + private + + -- Magic numbers + Initial_A : constant := 16#67452301#; + Initial_B : constant := 16#EFCDAB89#; + Initial_C : constant := 16#98BADCFE#; + Initial_D : constant := 16#10325476#; + + type Context is record + A : Interfaces.Unsigned_32 := Initial_A; + B : Interfaces.Unsigned_32 := Initial_B; + C : Interfaces.Unsigned_32 := Initial_C; + D : Interfaces.Unsigned_32 := Initial_D; + end record; + + Initial_Context : constant Context := + (A => Initial_A, B => Initial_B, C => Initial_C, D => Initial_D); + + end GNAT.MD5; diff -Nrc3pad gcc-3.2.3/gcc/ada/gmem.c gcc-3.3/gcc/ada/gmem.c *** gcc-3.2.3/gcc/ada/gmem.c 2002-05-04 03:28:06.000000000 +0000 --- gcc-3.3/gcc/ada/gmem.c 2002-10-23 07:33:24.000000000 +0000 *************** *** 4,10 **** * * * G M E M * * * - * $Revision: 1.3.12.1 $ * * * C Implementation File * * * --- 4,9 ---- *************** static FILE *gmemfile; *** 69,75 **** /* tb_len is the number of call level supported by this module */ #define TB_LEN 200 ! static char *tracebk [TB_LEN]; static int cur_tb_len, cur_tb_pos; extern void convert_addresses PARAMS ((char *[], int, void *, --- 68,74 ---- /* tb_len is the number of call level supported by this module */ #define TB_LEN 200 ! static char *tracebk[TB_LEN]; static int cur_tb_len, cur_tb_pos; extern void convert_addresses PARAMS ((char *[], int, void *, *************** __gnat_gmem_a2l_initialize (exename) *** 123,132 **** char *exename; { extern char **gnat_argv; ! char s [100]; int l; ! gnat_argv [0] = exename; convert_addresses (tracebk, 1, s, &l); } --- 122,131 ---- char *exename; { extern char **gnat_argv; ! char s[100]; int l; ! gnat_argv[0] = exename; convert_addresses (tracebk, 1, s, &l); } *************** __gnat_gmem_read_bt_frame (buf) *** 201,208 **** if (cur_tb_pos >= cur_tb_len) { ! buf [0] = ' '; ! buf [1] = '\0'; return; } --- 200,207 ---- if (cur_tb_pos >= cur_tb_len) { ! buf[0] = ' '; ! buf[1] = '\0'; return; } diff -Nrc3pad gcc-3.2.3/gcc/ada/g-moreex.adb gcc-3.3/gcc/ada/g-moreex.adb *** gcc-3.2.3/gcc/ada/g-moreex.adb 2002-05-07 08:22:16.000000000 +0000 --- gcc-3.3/gcc/ada/g-moreex.adb 2002-03-14 10:59:21.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/g-moreex.ads gcc-3.3/gcc/ada/g-moreex.ads *** gcc-3.2.3/gcc/ada/g-moreex.ads 2001-10-02 14:15:32.000000000 +0000 --- gcc-3.3/gcc/ada/g-moreex.ads 2002-03-14 10:59:21.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnat1drv.adb gcc-3.3/gcc/ada/gnat1drv.adb *** gcc-3.2.3/gcc/ada/gnat1drv.adb 2002-05-04 03:28:06.000000000 +0000 --- gcc-3.3/gcc/ada/gnat1drv.adb 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** begin *** 90,101 **** -- nested blocks, so that the outer one handles unrecoverable error. begin ! Osint.Initialize (Compiler); Scan_Compiler_Arguments; Osint.Add_Default_Search_Dirs; Sinput.Initialize; - Lib.Initialize; Sem.Initialize; Csets.Initialize; Uintp.Initialize; --- 89,103 ---- -- nested blocks, so that the outer one handles unrecoverable error. begin ! -- Lib.Initialize need to be called before Scan_Compiler_Arguments, ! -- because it initialize a table that is filled by ! -- Scan_Compiler_Arguments. ! ! Lib.Initialize; Scan_Compiler_Arguments; Osint.Add_Default_Search_Dirs; Sinput.Initialize; Sem.Initialize; Csets.Initialize; Uintp.Initialize; *************** begin *** 107,112 **** --- 109,122 ---- Inline.Initialize; Sem_Ch13.Initialize; + -- Acquire target parameters and perform required setup + + Targparm.Get_Target_Parameters; + + if Targparm.High_Integrity_Mode_On_Target then + Set_No_Run_Time_Mode; + end if; + -- Output copyright notice if full list mode if (Verbose_Mode or Full_List) *************** begin *** 114,130 **** then Write_Eol; Write_Str ("GNAT "); - Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1992-2001 Free Software Foundation, Inc."); - Write_Eol; - end if; - - -- Acquire target parameters and perform required setup ! Targparm.Get_Target_Parameters; ! if Targparm.High_Integrity_Mode_On_Target then ! Set_No_Run_Time_Mode; end if; -- Before we do anything else, adjust certain global values for --- 124,138 ---- then Write_Eol; Write_Str ("GNAT "); ! if Targparm.High_Integrity_Mode_On_Target then ! Write_Str ("Pro High Integrity "); ! end if; ! Write_Str (Gnat_Version_String); ! Write_Eol; ! Write_Str ("Copyright 1992-2002 Free Software Foundation, Inc."); ! Write_Eol; end if; -- Before we do anything else, adjust certain global values for *************** begin *** 173,178 **** --- 181,203 ---- end if; end if; + -- Set proper status for overflow checks. We turn on overflow checks + -- if -gnatp was not specified, and either -gnato is set or the back + -- end takes care of overflow checks. Otherwise we suppress overflow + -- checks by default (since front end checks are expensive). + + if not Opt.Suppress_Checks + and then (Opt.Enable_Overflow_Checks + or else + (Targparm.Backend_Divide_Checks_On_Target + and + Targparm.Backend_Overflow_Checks_On_Target)) + then + Suppress_Options.Overflow_Checks := False; + else + Suppress_Options.Overflow_Checks := True; + end if; + -- Check we have exactly one source file, this happens only in -- the case where the driver is called directly, it cannot happen -- when gnat1 is invoked from gcc in the normal case. diff -Nrc3pad gcc-3.2.3/gcc/ada/gnat1drv.ads gcc-3.3/gcc/ada/gnat1drv.ads *** gcc-3.2.3/gcc/ada/gnat1drv.ads 2002-05-07 08:22:17.000000000 +0000 --- gcc-3.3/gcc/ada/gnat1drv.ads 2002-10-23 07:33:24.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnat.ads gcc-3.3/gcc/ada/gnat.ads *** gcc-3.2.3/gcc/ada/gnat.ads 2001-10-02 14:15:35.000000000 +0000 --- gcc-3.3/gcc/ada/gnat.ads 2002-03-14 10:59:23.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1 $ -- -- -- Copyright (C) 1992-2000 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatbind.adb gcc-3.3/gcc/ada/gnatbind.adb *** gcc-3.2.3/gcc/ada/gnatbind.adb 2002-05-04 03:28:09.000000000 +0000 --- gcc-3.3/gcc/ada/gnatbind.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with Gnatvsn; use Gnatvsn; *** 39,46 **** --- 38,48 ---- with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; + with Osint.B; use Osint.B; with Output; use Output; with Switch; use Switch; + with Switch.B; use Switch.B; + with Targparm; use Targparm; with Types; use Types; procedure Gnatbind is *************** procedure Gnatbind is *** 86,94 **** Output_File_Name_Seen := True; if Argv'Length = 0 ! or else (Argv'Length >= 1 ! and then (Argv (1) = Switch_Character ! or else Argv (1) = '-')) then Fail ("output File_Name missing after -o"); --- 88,94 ---- Output_File_Name_Seen := True; if Argv'Length = 0 ! or else (Argv'Length >= 1 and then Argv (1) = '-') then Fail ("output File_Name missing after -o"); *************** procedure Gnatbind is *** 96,105 **** Output_File_Name := new String'(Argv); end if; ! elsif Argv'Length >= 2 ! and then (Argv (1) = Switch_Character ! or else Argv (1) = '-') ! then -- -I- if Argv (2 .. Argv'Last) = "I-" then --- 96,103 ---- Output_File_Name := new String'(Argv); end if; ! elsif Argv'Length >= 2 and then Argv (1) = '-' then ! -- -I- if Argv (2 .. Argv'Last) = "I-" then *************** procedure Gnatbind is *** 227,235 **** if Argv'Length > 4 and then Argv (Argv'Last - 3 .. Argv'Last) = ".ali" then ! Set_Main_File_Name (Argv); else ! Set_Main_File_Name (Argv & ".ali"); end if; end if; end Scan_Bind_Arg; --- 225,233 ---- if Argv'Length > 4 and then Argv (Argv'Last - 3 .. Argv'Last) = ".ali" then ! Add_File (Argv); else ! Add_File (Argv & ".ali"); end if; end if; end Scan_Bind_Arg; *************** procedure Gnatbind is *** 237,243 **** -- Start of processing for Gnatbind begin - Osint.Initialize (Binder); -- Set default for Shared_Libgnat option --- 235,240 ---- *************** begin *** 315,324 **** Osint.Add_Default_Search_Dirs; if Verbose_Mode then Write_Eol; Write_Str ("GNATBIND "); Write_Str (Gnat_Version_String); ! Write_Str (" Copyright 1995-2001 Free Software Foundation, Inc."); Write_Eol; end if; --- 312,329 ---- Osint.Add_Default_Search_Dirs; if Verbose_Mode then + Namet.Initialize; + Targparm.Get_Target_Parameters; + Write_Eol; Write_Str ("GNATBIND "); + + if Targparm.High_Integrity_Mode_On_Target then + Write_Str ("Pro High Integrity "); + end if; + Write_Str (Gnat_Version_String); ! Write_Str (" Copyright 1995-2002 Free Software Foundation, Inc."); Write_Eol; end if; diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatbind.ads gcc-3.3/gcc/ada/gnatbind.ads *** gcc-3.2.3/gcc/ada/gnatbind.ads 2002-05-07 08:22:17.000000000 +0000 --- gcc-3.3/gcc/ada/gnatbind.ads 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatbl.c gcc-3.3/gcc/ada/gnatbl.c *** gcc-3.2.3/gcc/ada/gnatbl.c 2002-05-04 03:28:11.000000000 +0000 --- gcc-3.3/gcc/ada/gnatbl.c 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** * * * C Implementation File * * * - * $Revision: 1.1.16.1 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * --- 6,11 ---- *************** addarg (str) *** 89,95 **** = (char **) xcalloc (link_arg_max + 1000, sizeof (char *)); for (i = 0; i <= link_arg_max; i++) ! new_link_args [i] = link_args [i]; if (link_args) free (link_args); --- 88,94 ---- = (char **) xcalloc (link_arg_max + 1000, sizeof (char *)); for (i = 0; i <= link_arg_max; i++) ! new_link_args[i] = link_args[i]; if (link_args) free (link_args); *************** addarg (str) *** 98,104 **** link_args = new_link_args; } ! link_args [link_arg_index] = str; } static void --- 97,103 ---- link_args = new_link_args; } ! link_args[link_arg_index] = str; } static void *************** process_args (p_argc, argv) *** 124,147 **** } /* -B is passed on to gcc */ ! if (! strncmp (argv [i], "-B", 2)) gcc_B_arg = argv[i]; /* -v turns on verbose option here and is passed on to gcc */ ! if (! strcmp (argv [i], "-v")) verbose = 1; ! if (! strcmp (argv [i], "-o")) { o_present = 1; ! exec_file_name = argv [i + 1]; } ! if (! strcmp (argv [i], "-g")) g_present = 1; ! if (! strcmp (argv [i], "-gnatbind")) { /* Explicit naming of binder. Grab the value then remove the two arguments from the argument list. */ --- 123,146 ---- } /* -B is passed on to gcc */ ! if (! strncmp (argv[i], "-B", 2)) gcc_B_arg = argv[i]; /* -v turns on verbose option here and is passed on to gcc */ ! if (! strcmp (argv[i], "-v")) verbose = 1; ! if (! strcmp (argv[i], "-o")) { o_present = 1; ! exec_file_name = argv[i + 1]; } ! if (! strcmp (argv[i], "-g")) g_present = 1; ! if (! strcmp (argv[i], "-gnatbind")) { /* Explicit naming of binder. Grab the value then remove the two arguments from the argument list. */ *************** process_args (p_argc, argv) *** 151,202 **** exit (1); } ! binder_path = __gnat_locate_exec (argv [i + 1], (char *) "."); if (!binder_path) { ! fprintf (stderr, "Could not locate binder: %s\n", argv [i + 1]); exit (1); } for (j = i + 2; j < *p_argc; j++) ! argv [j - 2] = argv [j]; (*p_argc) -= 2; i--; } ! else if (! strcmp (argv [i], "-linkonly")) { /* Don't call the binder. Set the flag and then remove the argument from the argument list. */ linkonly = 1; for (j = i + 1; j < *p_argc; j++) ! argv [j - 1] = argv [j]; ! (*p_argc) -= 1; i--; } ! else if (! strcmp (argv [i], "-gnatlink")) { /* Explicit naming of binder. Grab the value then remove the two arguments from the argument list. */ if (i + 1 >= *p_argc) ! { ! fprintf (stderr, "Missing argument for -gnatlink\n"); ! exit (1); ! } ! linker_path = __gnat_locate_exec (argv [i + 1], (char *) "."); if (!linker_path) { ! fprintf (stderr, "Could not locate linker: %s\n", argv [i + 1]); exit (1); } for (j = i + 2; j < *p_argc; j++) ! argv [j - 2] = argv [j]; ! (*p_argc) -= 2; i--; } } --- 150,201 ---- exit (1); } ! binder_path = __gnat_locate_exec (argv[i + 1], (char *) "."); if (!binder_path) { ! fprintf (stderr, "Could not locate binder: %s\n", argv[i + 1]); exit (1); } for (j = i + 2; j < *p_argc; j++) ! argv[j - 2] = argv[j]; (*p_argc) -= 2; i--; } ! else if (! strcmp (argv[i], "-linkonly")) { /* Don't call the binder. Set the flag and then remove the argument from the argument list. */ linkonly = 1; for (j = i + 1; j < *p_argc; j++) ! argv[j - 1] = argv[j]; ! *p_argc -= 1; i--; } ! else if (! strcmp (argv[i], "-gnatlink")) { /* Explicit naming of binder. Grab the value then remove the two arguments from the argument list. */ if (i + 1 >= *p_argc) ! { ! fprintf (stderr, "Missing argument for -gnatlink\n"); ! exit (1); ! } ! linker_path = __gnat_locate_exec (argv[i + 1], (char *) "."); if (!linker_path) { ! fprintf (stderr, "Could not locate linker: %s\n", argv[i + 1]); exit (1); } for (j = i + 2; j < *p_argc; j++) ! argv[j - 2] = argv[j]; ! *p_argc -= 2; i--; } } *************** main (argc, argv) *** 214,224 **** #ifdef VMS /* Warning: getenv only retrieves the first directory in VAXC$PATH */ char *pathval = ! strdup (__gnat_to_canonical_dir_spec (getenv ("VAXC$PATH"), 0)); #else char *pathval = getenv ("PATH"); #endif ! char *spawn_args [5]; int spawn_index = 0; #if defined (__EMX__) || defined(MSDOS) --- 213,223 ---- #ifdef VMS /* Warning: getenv only retrieves the first directory in VAXC$PATH */ char *pathval = ! xstrdup (__gnat_to_canonical_dir_spec (getenv ("VAXC$PATH"), 0)); #else char *pathval = getenv ("PATH"); #endif ! char *spawn_args[5]; int spawn_index = 0; #if defined (__EMX__) || defined(MSDOS) *************** main (argc, argv) *** 290,298 **** for (i = 1; i < argc; i++) { ! int arg_len = strlen (argv [i]); ! if (arg_len > 4 && ! strcmp (&argv [i][arg_len - 4], ".ali")) { if (done_an_ali) { --- 289,297 ---- for (i = 1; i < argc; i++) { ! int arg_len = strlen (argv[i]); ! if (arg_len > 4 && ! strcmp (&argv[i][arg_len - 4], ".ali")) { if (done_an_ali) { *************** main (argc, argv) *** 303,326 **** done_an_ali = 1; ! if (__gnat_is_regular_file (argv [i])) { ali_file_name = argv[i]; if (!linkonly) { /* Run gnatbind */ spawn_index = 0; ! spawn_args [spawn_index++] = binder_path; ! spawn_args [spawn_index++] = ali_file_name; for (j = 0 ; j <= bind_arg_index ; j++ ) ! spawn_args [spawn_index++] = bind_args [j]; ! spawn_args [spawn_index] = 0; if (verbose) { int i; for (i = 0; i < 2; i++) ! printf ("%s ", spawn_args [i]); putchar ('\n'); } --- 302,325 ---- done_an_ali = 1; ! if (__gnat_is_regular_file (argv[i])) { ali_file_name = argv[i]; if (!linkonly) { /* Run gnatbind */ spawn_index = 0; ! spawn_args[spawn_index++] = binder_path; ! spawn_args[spawn_index++] = ali_file_name; for (j = 0 ; j <= bind_arg_index ; j++ ) ! spawn_args[spawn_index++] = bind_args[j]; ! spawn_args[spawn_index] = 0; if (verbose) { int i; for (i = 0; i < 2; i++) ! printf ("%s ", spawn_args[i]); putchar ('\n'); } *************** main (argc, argv) *** 331,349 **** } } else ! addarg (argv [i]); } #ifdef MSDOS ! else if (!strcmp (argv [i], "-o")) { ! addarg (argv [i]); if (i < argc) i++; { char *ptr = strstr (argv[i], ".exe"); ! arg_len = strlen (argv [i]); coff2exe_args[1] = malloc (arg_len + 1); strcpy (coff2exe_args[1], argv[i]); if (ptr != NULL && strlen (ptr) == 4) --- 330,348 ---- } } else ! addarg (argv[i]); } #ifdef MSDOS ! else if (!strcmp (argv[i], "-o")) { ! addarg (argv[i]); if (i < argc) i++; { char *ptr = strstr (argv[i], ".exe"); ! arg_len = strlen (argv[i]); coff2exe_args[1] = malloc (arg_len + 1); strcpy (coff2exe_args[1], argv[i]); if (ptr != NULL && strlen (ptr) == 4) *************** main (argc, argv) *** 354,360 **** } #endif else ! addarg (argv [i]); } if (! done_an_ali) --- 353,359 ---- } #endif else ! addarg (argv[i]); } if (! done_an_ali) *************** main (argc, argv) *** 371,377 **** int i; for (i = 0; i < link_arg_index; i++) ! printf ("%s ", link_args [i]); putchar ('\n'); } --- 370,376 ---- int i; for (i = 0; i < link_arg_index; i++) ! printf ("%s ", link_args[i]); putchar ('\n'); } diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatchop.adb gcc-3.3/gcc/ada/gnatchop.adb *** gcc-3.2.3/gcc/ada/gnatchop.adb 2001-12-16 01:13:40.000000000 +0000 --- gcc-3.3/gcc/ada/gnatchop.adb 2002-03-14 10:59:24.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.4 $ -- -- -- Copyright (C) 1998-2001 Ada Core Technologies, Inc. -- -- -- --- 6,11 ---- *************** procedure Gnatchop is *** 49,54 **** --- 48,59 ---- Config_File_Name : constant String_Access := new String'("gnat.adc"); -- The name of the file holding the GNAT configuration pragmas + Gcc : String_Access := new String'("gcc"); + -- May be modified by switch --GCC= + + Gcc_Set : Boolean := False; + -- True if a switch --GCC= is used + Gnat_Cmd : String_Access; -- Command to execute the GNAT compiler *************** procedure Gnatchop is *** 223,231 **** Integer'Image (Maximum_File_Name_Length); ! function Locate_Executable (Program_Name : String) return String_Access; -- Locate executable for given program name. This takes into account ! -- the target-prefix of the current command. subtype EOL_Length is Natural range 0 .. 2; -- Possible lengths of end of line sequence --- 228,239 ---- Integer'Image (Maximum_File_Name_Length); ! function Locate_Executable ! (Program_Name : String; ! Look_For_Prefix : Boolean := True) ! return String_Access; -- Locate executable for given program name. This takes into account ! -- the target-prefix of the current command, if Look_For_Prefix is True. subtype EOL_Length is Natural range 0 .. 2; -- Possible lengths of end of line sequence *************** procedure Gnatchop is *** 492,526 **** -- Locate_Executable -- ----------------------- ! function Locate_Executable (Program_Name : String) return String_Access is Current_Command : constant String := Command_Name; ! End_Of_Prefix : Natural; Start_Of_Prefix : Positive := Current_Command'First; Result : String_Access; begin - -- Find Start_Of_Prefix ! for J in reverse Current_Command'Range loop ! if Current_Command (J) = '/' or ! Current_Command (J) = Directory_Separator or ! Current_Command (J) = ':' ! then ! Start_Of_Prefix := J + 1; ! exit; ! end if; ! end loop; ! -- Find End_Of_Prefix ! End_Of_Prefix := Start_Of_Prefix - 1; ! for J in reverse Start_Of_Prefix .. Current_Command'Last loop ! if Current_Command (J) = '-' then ! End_Of_Prefix := J; ! exit; ! end if; ! end loop; declare Command : constant String := --- 500,541 ---- -- Locate_Executable -- ----------------------- ! function Locate_Executable ! (Program_Name : String; ! Look_For_Prefix : Boolean := True) ! return String_Access ! is Current_Command : constant String := Command_Name; ! End_Of_Prefix : Natural := Current_Command'First - 1; Start_Of_Prefix : Positive := Current_Command'First; Result : String_Access; begin ! if Look_For_Prefix then ! -- Find Start_Of_Prefix ! for J in reverse Current_Command'Range loop ! if Current_Command (J) = '/' or ! Current_Command (J) = Directory_Separator or ! Current_Command (J) = ':' ! then ! Start_Of_Prefix := J + 1; ! exit; ! end if; ! end loop; ! -- Find End_Of_Prefix ! End_Of_Prefix := Start_Of_Prefix - 1; ! ! for J in reverse Start_Of_Prefix .. Current_Command'Last loop ! if Current_Command (J) = '-' then ! End_Of_Prefix := J; ! exit; ! end if; ! end loop; ! end if; declare Command : constant String := *************** procedure Gnatchop is *** 1058,1067 **** -- Scan options first loop ! case Getopt ("c gnat? h k? p q r v w x") is when ASCII.NUL => exit; when 'c' => Compilation_Mode := True; --- 1073,1086 ---- -- Scan options first loop ! case Getopt ("c gnat? h k? p q r v w x -GCC=!") is when ASCII.NUL => exit; + when '-' => + Gcc := new String'(Parameter); + Gcc_Set := True; + when 'c' => Compilation_Mode := True; *************** procedure Gnatchop is *** 1300,1306 **** begin Put_Line ("Usage: gnatchop [-c] [-h] [-k#] " & ! "[-r] [-p] [-q] [-v] [-w] [-x] file [file ...] [dir]"); New_Line; Put_Line --- 1319,1325 ---- begin Put_Line ("Usage: gnatchop [-c] [-h] [-k#] " & ! "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]"); New_Line; Put_Line *************** procedure Gnatchop is *** 1343,1348 **** --- 1362,1370 ---- Put_Line (" -x exit on error"); + Put_Line + (" --GCC=xx specify the path of the gnat parser to be used"); + New_Line; Put_Line (" file... list of source files to be chopped"); *************** procedure Gnatchop is *** 1638,1651 **** -- Start of processing for gnatchop begin - -- Check presence of required executables - - Gnat_Cmd := Locate_Executable ("gcc"); - - if Gnat_Cmd = null then - goto No_Files_Written; - end if; - -- Process command line options and initialize global variables if not Scan_Arguments then --- 1660,1665 ---- *************** begin *** 1653,1658 **** --- 1667,1680 ---- return; end if; + -- Check presence of required executables + + Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set); + + if Gnat_Cmd = null then + goto No_Files_Written; + end if; + -- First parse all files and read offset information for Num in 1 .. File.Last loop diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatcmd.adb gcc-3.3/gcc/ada/gnatcmd.adb *** gcc-3.2.3/gcc/ada/gnatcmd.adb 2002-05-04 03:28:11.000000000 +0000 --- gcc-3.3/gcc/ada/gnatcmd.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.8.10.1 $ -- -- ! -- 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,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- -- *************** *** 26,47 **** -- -- ------------------------------------------------------------------------------ ! with Ada.Characters.Handling; use Ada.Characters.Handling; ! with Ada.Command_Line; use Ada.Command_Line; ! with Ada.Text_IO; use Ada.Text_IO; with Osint; use Osint; with Sdefault; use Sdefault; with Hostparm; use Hostparm; -- Used to determine if we are in VMS or not for error message purposes with Gnatvsn; with GNAT.OS_Lib; use GNAT.OS_Lib; with Table; procedure GNATCmd is ! pragma Ident (Gnatvsn.Gnat_Version_String); ------------------ -- SWITCH TABLE -- --- 25,96 ---- -- -- ------------------------------------------------------------------------------ ! with GNAT.Directory_Operations; use GNAT.Directory_Operations; + with Csets; + with MLib.Tgt; + with MLib.Utl; + with Namet; use Namet; + with Opt; with Osint; use Osint; + with Output; + with Prj; use Prj; + with Prj.Env; + with Prj.Ext; use Prj.Ext; + with Prj.Pars; + with Prj.Util; use Prj.Util; with Sdefault; use Sdefault; + with Snames; use Snames; + with Stringt; use Stringt; + with Table; + with Types; use Types; with Hostparm; use Hostparm; -- Used to determine if we are in VMS or not for error message purposes + with Ada.Characters.Handling; use Ada.Characters.Handling; + with Ada.Command_Line; use Ada.Command_Line; + with Ada.Text_IO; use Ada.Text_IO; + with Gnatvsn; with GNAT.OS_Lib; use GNAT.OS_Lib; with Table; procedure GNATCmd is ! ! Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; ! Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; ! ! Project_File : String_Access; ! Project : Prj.Project_Id; ! Current_Verbosity : Prj.Verbosity := Prj.Default; ! Tool_Package_Name : Name_Id := No_Name; ! ! -- This flag indicates a switch -p (for gnatxref and gnatfind) for ! -- an old fashioned project file. -p cannot be used in conjonction ! -- with -P. ! ! Old_Project_File_Used : Boolean := False; ! ! -- A table to keep the switches on the command line ! ! package Last_Switches is new Table.Table ! (Table_Component_Type => String_Access, ! Table_Index_Type => Integer, ! Table_Low_Bound => 1, ! Table_Initial => 20, ! Table_Increment => 100, ! Table_Name => "Gnatcmd.Last_Switches"); ! ! -- A table to keep the switches from the project file ! ! package First_Switches is new Table.Table ! (Table_Component_Type => String_Access, ! Table_Index_Type => Integer, ! Table_Low_Bound => 1, ! Table_Initial => 20, ! Table_Increment => 100, ! Table_Name => "Gnatcmd.First_Switches"); ------------------ -- SWITCH TABLE -- *************** procedure GNATCmd is *** 56,61 **** --- 105,111 ---- -- DIRECT_TRANSLATION -- | DIRECTORIES_TRANSLATION -- | FILE_TRANSLATION + -- | NO_SPACE_FILE_TRANSL -- | NUMERIC_TRANSLATION -- | STRING_TRANSLATION -- | OPTIONS_TRANSLATION *************** procedure GNATCmd is *** 67,72 **** --- 117,123 ---- -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH * -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH % -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @ + -- NO_SPACE_FILE_TRANSL ::= =< UNIX_SWITCH > -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number # -- STRING_TRANSLATION ::= =" UNIX_SWITCH " -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION} *************** procedure GNATCmd is *** 106,111 **** --- 157,165 ---- -- file is allowed, not a list of files, and only one unix switch is -- generated as a result. + -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that + -- no space is inserted between the switch and the file name. + -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case -- except that the parameter is a decimal integer in the range 0 to 999. *************** procedure GNATCmd is *** 169,176 **** S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & "-X" & '"'; ! S_Project_File : aliased constant S := "/PROJECT_FILE=*" & ! "-P*"; S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" & "DEFAULT " & "-vP0 " & --- 223,230 ---- S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & "-X" & '"'; ! S_Project_File : aliased constant S := "/PROJECT_FILE=<" & ! "-P>"; S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" & "DEFAULT " & "-vP0 " & *************** procedure GNATCmd is *** 220,231 **** --- 274,299 ---- S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" & "-m#"; + S_Bind_Help : aliased constant S := "/HELP " & + "-h"; + + S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" & + "INVALID " & + "-Sin " & + "LOW " & + "-Slo " & + "HIGH " & + "-Shi"; + S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-aO*"; S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " & "-K"; + S_Bind_List : aliased constant S := "/LIST_RESTRICTIONS " & + "-r"; + S_Bind_Main : aliased constant S := "/MAIN " & "!-n"; *************** procedure GNATCmd is *** 235,240 **** --- 303,311 ---- S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & "-nostdlib"; + S_Bind_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " & + "-t"; + S_Bind_Object : aliased constant S := "/OBJECT_LIST " & "-O"; *************** procedure GNATCmd is *** 261,268 **** S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " & "-x"; ! S_Bind_Rename : aliased constant S := "/RENAME_MAIN " & ! "-r"; S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" & "VERBOSE " & --- 332,339 ---- S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " & "-x"; ! S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" & ! "-M>"; S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" & "VERBOSE " & *************** procedure GNATCmd is *** 275,285 **** S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " & "!-b,!-v"; S_Bind_Search : aliased constant S := "/SEARCH=*" & "-I*"; S_Bind_Shared : aliased constant S := "/SHARED " & ! "-shared"; S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; --- 346,365 ---- S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " & "!-b,!-v"; + S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " & + "-r"; + + S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & + "--RTS=|"; + S_Bind_Search : aliased constant S := "/SEARCH=*" & "-I*"; S_Bind_Shared : aliased constant S := "/SHARED " & ! "-shared"; ! ! S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" & ! "-T#"; S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; *************** procedure GNATCmd is *** 299,339 **** "-we"; S_Bind_WarnX : aliased constant S := "/NOWARNINGS " & ! "-ws"; ! Bind_Switches : aliased constant Switches := ( ! S_Bind_Bind 'Access, ! S_Bind_Build 'Access, ! S_Bind_Current 'Access, ! S_Bind_Debug 'Access, ! S_Bind_DebugX 'Access, ! S_Bind_Elab 'Access, ! S_Bind_Error 'Access, ! S_Ext_Ref 'Access, ! S_Bind_Library 'Access, ! S_Bind_Linker 'Access, ! S_Bind_Main 'Access, ! S_Bind_Nostinc 'Access, ! S_Bind_Nostlib 'Access, ! S_Bind_Object 'Access, ! S_Bind_Order 'Access, ! S_Bind_Output 'Access, ! S_Bind_OutputX 'Access, ! S_Bind_Pess 'Access, ! S_Project_File 'Access, ! S_Project_Verb 'Access, ! S_Bind_Read 'Access, ! S_Bind_ReadX 'Access, ! S_Bind_Rename 'Access, ! S_Bind_Report 'Access, ! S_Bind_ReportX 'Access, ! S_Bind_Search 'Access, ! S_Bind_Shared 'Access, ! S_Bind_Source 'Access, ! S_Bind_Time 'Access, ! S_Bind_Verbose 'Access, ! S_Bind_Warn 'Access, ! S_Bind_WarnX 'Access); ---------------------------- -- Switches for GNAT CHOP -- --- 379,426 ---- "-we"; S_Bind_WarnX : aliased constant S := "/NOWARNINGS " & ! "-ws"; ! Bind_Switches : aliased constant Switches := ! (S_Bind_Bind 'Access, ! S_Bind_Build 'Access, ! S_Bind_Current 'Access, ! S_Bind_Debug 'Access, ! S_Bind_DebugX 'Access, ! S_Bind_Elab 'Access, ! S_Bind_Error 'Access, ! S_Ext_Ref 'Access, ! S_Bind_Help 'Access, ! S_Bind_Init 'Access, ! S_Bind_Library 'Access, ! S_Bind_Linker 'Access, ! S_Bind_List 'Access, ! S_Bind_Main 'Access, ! S_Bind_Nostinc 'Access, ! S_Bind_Nostlib 'Access, ! S_Bind_No_Time 'Access, ! S_Bind_Object 'Access, ! S_Bind_Order 'Access, ! S_Bind_Output 'Access, ! S_Bind_OutputX 'Access, ! S_Bind_Pess 'Access, ! S_Project_File 'Access, ! S_Project_Verb 'Access, ! S_Bind_Read 'Access, ! S_Bind_ReadX 'Access, ! S_Bind_Rename 'Access, ! S_Bind_Report 'Access, ! S_Bind_ReportX 'Access, ! S_Bind_Restr 'Access, ! S_Bind_RTS 'Access, ! S_Bind_Search 'Access, ! S_Bind_Shared 'Access, ! S_Bind_Slice 'Access, ! S_Bind_Source 'Access, ! S_Bind_Time 'Access, ! S_Bind_Verbose 'Access, ! S_Bind_Warn 'Access, ! S_Bind_WarnX 'Access); ---------------------------- -- Switches for GNAT CHOP -- *************** procedure GNATCmd is *** 363,390 **** S_Chop_Verb : aliased constant S := "/VERBOSE " & "-v"; ! Chop_Switches : aliased constant Switches := ( ! S_Chop_Comp 'Access, ! S_Chop_File 'Access, ! S_Chop_Help 'Access, ! S_Chop_Over 'Access, ! S_Chop_Pres 'Access, ! S_Chop_Quiet 'Access, ! S_Chop_Ref 'Access, ! S_Chop_Verb 'Access); ------------------------------- -- Switches for GNAT COMPILE -- ------------------------------- S_GCC_Ada_83 : aliased constant S := "/83 " & ! "-gnat83"; S_GCC_Ada_95 : aliased constant S := "/95 " & ! "!-gnat83"; S_GCC_Asm : aliased constant S := "/ASM " & ! "-S,!-c"; S_GCC_Checks : aliased constant S := "/CHECKS=" & "FULL " & --- 450,477 ---- S_Chop_Verb : aliased constant S := "/VERBOSE " & "-v"; ! Chop_Switches : aliased constant Switches := ! (S_Chop_Comp 'Access, ! S_Chop_File 'Access, ! S_Chop_Help 'Access, ! S_Chop_Over 'Access, ! S_Chop_Pres 'Access, ! S_Chop_Quiet 'Access, ! S_Chop_Ref 'Access, ! S_Chop_Verb 'Access); ------------------------------- -- Switches for GNAT COMPILE -- ------------------------------- S_GCC_Ada_83 : aliased constant S := "/83 " & ! "-gnat83"; S_GCC_Ada_95 : aliased constant S := "/95 " & ! "!-gnat83"; S_GCC_Asm : aliased constant S := "/ASM " & ! "-S,!-c"; S_GCC_Checks : aliased constant S := "/CHECKS=" & "FULL " & *************** procedure GNATCmd is *** 404,413 **** "-gnatp,!-gnato,!-gnatE"; S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " & ! "-gnatC"; S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " & ! "!-I-"; S_GCC_Debug : aliased constant S := "/DEBUG=" & "SYMBOLS " & --- 491,503 ---- "-gnatp,!-gnato,!-gnatE"; S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " & ! "-gnatC"; ! ! S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & ! "-gnatec>"; S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " & ! "!-I-"; S_GCC_Debug : aliased constant S := "/DEBUG=" & "SYMBOLS " & *************** procedure GNATCmd is *** 424,436 **** "-g0"; S_GCC_DebugX : aliased constant S := "/NODEBUG " & ! "!-g"; S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" & "RECEIVER " & "-gnatzr " & "CALLER " & ! "-gnatzc"; S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " & "!-gnatzr,!-gnatzc"; --- 514,526 ---- "-g0"; S_GCC_DebugX : aliased constant S := "/NODEBUG " & ! "!-g"; S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" & "RECEIVER " & "-gnatzr " & "CALLER " & ! "-gnatzc"; S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " & "!-gnatzr,!-gnatzc"; *************** procedure GNATCmd is *** 453,458 **** --- 543,551 ---- S_GCC_Force : aliased constant S := "/FORCE_ALI " & "-gnatQ"; + S_GCC_Help : aliased constant S := "/HELP " & + "-gnath"; + S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" & "DEFAULT " & "-gnati1 " & *************** procedure GNATCmd is *** 480,502 **** S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " & "-gnati1"; S_GCC_Inline : aliased constant S := "/INLINE=" & "PRAGMA " & "-gnatn " & "SUPPRESS " & ! "-fno-inline"; S_GCC_InlineX : aliased constant S := "/NOINLINE " & ! "!-gnatn"; S_GCC_List : aliased constant S := "/LIST " & ! "-gnatl"; S_GCC_Noload : aliased constant S := "/NOLOAD " & ! "-gnatc"; S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & ! "-nostdinc"; S_GCC_Opt : aliased constant S := "/OPTIMIZE=" & "ALL " & --- 573,609 ---- S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " & "-gnati1"; + S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " & + "-gnatdO"; + S_GCC_Inline : aliased constant S := "/INLINE=" & "PRAGMA " & "-gnatn " & + "FULL " & + "-gnatN " & "SUPPRESS " & ! "-fno-inline"; S_GCC_InlineX : aliased constant S := "/NOINLINE " & ! "!-gnatn"; ! ! S_GCC_Jumps : aliased constant S := "/LONGJMP_SETJMP " & ! "-gnatL"; ! ! S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" & ! "-gnatyM#"; S_GCC_List : aliased constant S := "/LIST " & ! "-gnatl"; ! ! S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " & ! "-gnatA"; S_GCC_Noload : aliased constant S := "/NOLOAD " & ! "-gnatc"; S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & ! "-nostdinc"; S_GCC_Opt : aliased constant S := "/OPTIMIZE=" & "ALL " & *************** procedure GNATCmd is *** 515,520 **** --- 622,630 ---- S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " & "-O0,!-O1,!-O2,!-O3"; + S_GCC_Polling : aliased constant S := "/POLLING " & + "-gnatP"; + S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" & "VERBOSE " & "-gnatv " & *************** procedure GNATCmd is *** 532,546 **** S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" & "ARRAYS " & ! "-gnatR1 " & "NONE " & ! "-gnatR0 " & "OBJECTS " & ! "-gnatR2 " & "SYMBOLIC " & ! "-gnatR3 " & "DEFAULT " & ! "-gnatR"; S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " & "!-gnatR"; --- 642,656 ---- S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" & "ARRAYS " & ! "-gnatR1 " & "NONE " & ! "-gnatR0 " & "OBJECTS " & ! "-gnatR2 " & "SYMBOLIC " & ! "-gnatR3 " & "DEFAULT " & ! "-gnatR"; S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " & "!-gnatR"; *************** procedure GNATCmd is *** 599,605 **** "!-gnatg,!-gnatr " & "PRAGMA " & "-gnatyp " & ! "REFERENCES " & "-gnatr " & "SPECS " & "-gnatys " & --- 709,715 ---- "!-gnatg,!-gnatr " & "PRAGMA " & "-gnatyp " & ! "RM_COLUMN_LAYOUT " & "-gnatr " & "SPECS " & "-gnatys " & *************** procedure GNATCmd is *** 632,676 **** S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" & "DEFAULT " & ! "-gnatVd " & "NODEFAULT " & ! "-gnatVD " & "COPIES " & ! "-gnatVc " & "NOCOPIES " & ! "-gnatVC " & "FLOATS " & ! "-gnatVf " & "NOFLOATS " & ! "-gnatVF " & "IN_PARAMS " & ! "-gnatVi " & "NOIN_PARAMS " & ! "-gnatVI " & "MOD_PARAMS " & ! "-gnatVm " & "NOMOD_PARAMS " & ! "-gnatVM " & "OPERANDS " & ! "-gnatVo " & "NOOPERANDS " & ! "-gnatVO " & "RETURNS " & ! "-gnatVr " & "NORETURNS " & ! "-gnatVR " & "SUBSCRIPTS " & ! "-gnatVs " & "NOSUBSCRIPTS " & ! "-gnatVS " & "TESTS " & ! "-gnatVt " & "NOTESTS " & ! "-gnatVT " & "ALL " & ! "-gnatVa " & "NONE " & ! "-gnatVn"; S_GCC_Verbose : aliased constant S := "/VERBOSE " & "-v"; --- 742,786 ---- S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" & "DEFAULT " & ! "-gnatVd " & "NODEFAULT " & ! "-gnatVD " & "COPIES " & ! "-gnatVc " & "NOCOPIES " & ! "-gnatVC " & "FLOATS " & ! "-gnatVf " & "NOFLOATS " & ! "-gnatVF " & "IN_PARAMS " & ! "-gnatVi " & "NOIN_PARAMS " & ! "-gnatVI " & "MOD_PARAMS " & ! "-gnatVm " & "NOMOD_PARAMS " & ! "-gnatVM " & "OPERANDS " & ! "-gnatVo " & "NOOPERANDS " & ! "-gnatVO " & "RETURNS " & ! "-gnatVr " & "NORETURNS " & ! "-gnatVR " & "SUBSCRIPTS " & ! "-gnatVs " & "NOSUBSCRIPTS " & ! "-gnatVS " & "TESTS " & ! "-gnatVt " & "NOTESTS " & ! "-gnatVT " & "ALL " & ! "-gnatVa " & "NONE " & ! "-gnatVn"; S_GCC_Verbose : aliased constant S := "/VERBOSE " & "-v"; *************** procedure GNATCmd is *** 680,689 **** --- 790,807 ---- "!-gnatws,!-gnatwe " & "ALL_GCC " & "-Wall " & + "BIASED_ROUNDING " & + "-gnatwb " & + "NOBIASED_ROUNDING " & + "-gnatwB " & "CONDITIONALS " & "-gnatwc " & "NOCONDITIONALS " & "-gnatwC " & + "IMPLICIT_DEREFERENCE " & + "-gnatwd " & + "NO_IMPLICIT_DEREFERENCE " & + "-gnatwD " & "ELABORATION " & "-gnatwl " & "NOELABORATION " & *************** procedure GNATCmd is *** 698,703 **** --- 816,825 ---- "-gnatwi " & "NOIMPLEMENTATION " & "-gnatwI " & + "INEFFECTIVE_INLINE " & + "-gnatwp " & + "NOINEFFECTIVE_INLINE " & + "-gnatwP " & "OPTIONAL " & "-gnatwa " & "NOOPTIONAL " & *************** procedure GNATCmd is *** 714,719 **** --- 836,845 ---- "-gnatws " & "UNINITIALIZED " & "-Wuninitialized " & + "UNREFERENCED_FORMALS " & + "-gnatwf " & + "NOUNREFERENCED_FORMALS " & + "-gnatwF " & "UNUSED " & "-gnatwu " & "NOUNUSED " & *************** procedure GNATCmd is *** 739,804 **** "-gnatWe"; S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " & ! "-gnatWn"; S_GCC_Xdebug : aliased constant S := "/XDEBUG " & ! "-gnatD"; S_GCC_Xref : aliased constant S := "/XREF=" & "GENERATE " & ! "!-gnatx " & "SUPPRESS " & ! "-gnatx"; ! GCC_Switches : aliased constant Switches := ( ! S_GCC_Ada_83 'Access, ! S_GCC_Ada_95 'Access, ! S_GCC_Asm 'Access, ! S_GCC_Checks 'Access, ! S_GCC_ChecksX 'Access, ! S_GCC_Compres 'Access, ! S_GCC_Current 'Access, ! S_GCC_Debug 'Access, ! S_GCC_DebugX 'Access, ! S_GCC_Dist 'Access, ! S_GCC_DistX 'Access, ! S_GCC_Error 'Access, ! S_GCC_ErrorX 'Access, ! S_GCC_Expand 'Access, ! S_GCC_Extend 'Access, ! S_GCC_File 'Access, ! S_GCC_Force 'Access, ! S_GCC_Ident 'Access, ! S_GCC_IdentX 'Access, ! S_GCC_Inline 'Access, ! S_GCC_InlineX 'Access, ! S_GCC_List 'Access, ! S_GCC_Noload 'Access, ! S_GCC_Nostinc 'Access, ! S_GCC_Opt 'Access, ! S_GCC_OptX 'Access, ! S_GCC_Report 'Access, ! S_GCC_ReportX 'Access, ! S_GCC_Repinfo 'Access, ! S_GCC_RepinfX 'Access, ! S_GCC_Search 'Access, ! S_GCC_Style 'Access, ! S_GCC_StyleX 'Access, ! S_GCC_Syntax 'Access, ! S_GCC_Trace 'Access, ! S_GCC_Tree 'Access, ! S_GCC_Trys 'Access, ! S_GCC_Units 'Access, ! S_GCC_Unique 'Access, ! S_GCC_Upcase 'Access, ! S_GCC_Valid 'Access, ! S_GCC_Verbose 'Access, ! S_GCC_Warn 'Access, ! S_GCC_WarnX 'Access, ! S_GCC_Wide 'Access, ! S_GCC_WideX 'Access, ! S_GCC_Xdebug 'Access, ! S_GCC_Xref 'Access); ---------------------------- -- Switches for GNAT ELIM -- --- 865,940 ---- "-gnatWe"; S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " & ! "-gnatWn"; S_GCC_Xdebug : aliased constant S := "/XDEBUG " & ! "-gnatD"; S_GCC_Xref : aliased constant S := "/XREF=" & "GENERATE " & ! "!-gnatx " & "SUPPRESS " & ! "-gnatx"; ! GCC_Switches : aliased constant Switches := ! (S_GCC_Ada_83 'Access, ! S_GCC_Ada_95 'Access, ! S_GCC_Asm 'Access, ! S_GCC_Checks 'Access, ! S_GCC_ChecksX 'Access, ! S_GCC_Compres 'Access, ! S_GCC_Config 'Access, ! S_GCC_Current 'Access, ! S_GCC_Debug 'Access, ! S_GCC_DebugX 'Access, ! S_GCC_Dist 'Access, ! S_GCC_DistX 'Access, ! S_GCC_Error 'Access, ! S_GCC_ErrorX 'Access, ! S_GCC_Expand 'Access, ! S_GCC_Extend 'Access, ! S_Ext_Ref 'Access, ! S_GCC_File 'Access, ! S_GCC_Force 'Access, ! S_GCC_Help 'Access, ! S_GCC_Ident 'Access, ! S_GCC_IdentX 'Access, ! S_GCC_Immed 'Access, ! S_GCC_Inline 'Access, ! S_GCC_InlineX 'Access, ! S_GCC_Jumps 'Access, ! S_GCC_Length 'Access, ! S_GCC_List 'Access, ! S_GCC_Noadc 'Access, ! S_GCC_Noload 'Access, ! S_GCC_Nostinc 'Access, ! S_GCC_Opt 'Access, ! S_GCC_OptX 'Access, ! S_GCC_Polling 'Access, ! S_Project_File'Access, ! S_Project_Verb'Access, ! S_GCC_Report 'Access, ! S_GCC_ReportX 'Access, ! S_GCC_Repinfo 'Access, ! S_GCC_RepinfX 'Access, ! S_GCC_Search 'Access, ! S_GCC_Style 'Access, ! S_GCC_StyleX 'Access, ! S_GCC_Syntax 'Access, ! S_GCC_Trace 'Access, ! S_GCC_Tree 'Access, ! S_GCC_Trys 'Access, ! S_GCC_Units 'Access, ! S_GCC_Unique 'Access, ! S_GCC_Upcase 'Access, ! S_GCC_Valid 'Access, ! S_GCC_Verbose 'Access, ! S_GCC_Warn 'Access, ! S_GCC_WarnX 'Access, ! S_GCC_Wide 'Access, ! S_GCC_WideX 'Access, ! S_GCC_Xdebug 'Access, ! S_GCC_Xref 'Access); ---------------------------- -- Switches for GNAT ELIM -- *************** procedure GNATCmd is *** 807,822 **** S_Elim_All : aliased constant S := "/ALL " & "-a"; S_Elim_Miss : aliased constant S := "/MISSED " & "-m"; S_Elim_Verb : aliased constant S := "/VERBOSE " & "-v"; ! Elim_Switches : aliased constant Switches := ( ! S_Elim_All 'Access, ! S_Elim_Miss 'Access, ! S_Elim_Verb 'Access); ---------------------------- -- Switches for GNAT FIND -- --- 943,970 ---- S_Elim_All : aliased constant S := "/ALL " & "-a"; + S_Elim_Bind : aliased constant S := "/BIND_FILE=<" & + "-b>"; + S_Elim_Miss : aliased constant S := "/MISSED " & "-m"; + S_Elim_Quiet : aliased constant S := "/QUIET " & + "-q"; + + S_Elim_Tree : aliased constant S := "/TREE_DIRS=*" & + "-T*"; + S_Elim_Verb : aliased constant S := "/VERBOSE " & "-v"; ! Elim_Switches : aliased constant Switches := ! (S_Elim_All 'Access, ! S_Elim_Bind 'Access, ! S_Elim_Miss 'Access, ! S_Elim_Quiet 'Access, ! S_Elim_Tree 'Access, ! S_Elim_Verb 'Access); ---------------------------- -- Switches for GNAT FIND -- *************** procedure GNATCmd is *** 825,830 **** --- 973,981 ---- S_Find_All : aliased constant S := "/ALL_FILES " & "-a"; + S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " & + "-d"; + S_Find_Expr : aliased constant S := "/EXPRESSIONS " & "-e"; *************** procedure GNATCmd is *** 834,839 **** --- 985,996 ---- S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " & "-g"; + S_Find_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" & "-aO*"; *************** procedure GNATCmd is *** 852,863 **** S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; ! Find_Switches : aliased constant Switches := ( ! S_Find_All 'Access, S_Find_Expr 'Access, S_Ext_Ref 'Access, S_Find_Full 'Access, S_Find_Ignore 'Access, S_Find_Object 'Access, S_Find_Print 'Access, S_Find_Project 'Access, --- 1009,1026 ---- S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; ! S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " & ! "-t"; ! ! Find_Switches : aliased constant Switches := ! (S_Find_All 'Access, ! S_Find_Deriv 'Access, S_Find_Expr 'Access, S_Ext_Ref 'Access, S_Find_Full 'Access, S_Find_Ignore 'Access, + S_Find_Nostinc 'Access, + S_Find_Nostlib 'Access, S_Find_Object 'Access, S_Find_Print 'Access, S_Find_Project 'Access, *************** procedure GNATCmd is *** 865,871 **** S_Project_Verb 'Access, S_Find_Ref 'Access, S_Find_Search 'Access, ! S_Find_Source 'Access); ------------------------------ -- Switches for GNAT KRUNCH -- --- 1028,1035 ---- S_Project_Verb 'Access, S_Find_Ref 'Access, S_Find_Search 'Access, ! S_Find_Source 'Access, ! S_Find_Types 'Access); ------------------------------ -- Switches for GNAT KRUNCH -- *************** procedure GNATCmd is *** 874,881 **** S_Krunch_Count : aliased constant S := "/COUNT=#" & "`#"; ! Krunch_Switches : aliased constant Switches := (1 .. 1 => ! S_Krunch_Count 'Access); ------------------------------- -- Switches for GNAT LIBRARY -- --- 1038,1045 ---- S_Krunch_Count : aliased constant S := "/COUNT=#" & "`#"; ! Krunch_Switches : aliased constant Switches := ! (1 .. 1 => S_Krunch_Count 'Access); ------------------------------- -- Switches for GNAT LIBRARY -- *************** procedure GNATCmd is *** 885,903 **** "--config=@"; S_Lbr_Create : aliased constant S := "/CREATE=%" & ! "--create=%"; S_Lbr_Delete : aliased constant S := "/DELETE=%" & ! "--delete=%"; S_Lbr_Set : aliased constant S := "/SET=%" & ! "--set=%"; ! Lbr_Switches : aliased constant Switches := ( ! S_Lbr_Config 'Access, ! S_Lbr_Create 'Access, ! S_Lbr_Delete 'Access, ! S_Lbr_Set 'Access); ---------------------------- -- Switches for GNAT LINK -- --- 1049,1067 ---- "--config=@"; S_Lbr_Create : aliased constant S := "/CREATE=%" & ! "--create=%"; S_Lbr_Delete : aliased constant S := "/DELETE=%" & ! "--delete=%"; S_Lbr_Set : aliased constant S := "/SET=%" & ! "--set=%"; ! Lbr_Switches : aliased constant Switches := ! (S_Lbr_Config 'Access, ! S_Lbr_Create 'Access, ! S_Lbr_Delete 'Access, ! S_Lbr_Set 'Access); ---------------------------- -- Switches for GNAT LINK -- *************** procedure GNATCmd is *** 922,927 **** --- 1086,1094 ---- S_Link_Execut : aliased constant S := "/EXECUTABLE=@" & "-o@"; + S_Link_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " & + "-f"; + S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' & "--for-linker=IDENT=" & '"'; *************** procedure GNATCmd is *** 944,954 **** S_Link_ZZZZZ : aliased constant S := "/ " & "--for-linker="; ! Link_Switches : aliased constant Switches := ( ! S_Link_Bind 'Access, S_Link_Debug 'Access, S_Link_Execut 'Access, S_Ext_Ref 'Access, S_Link_Ident 'Access, S_Link_Nocomp 'Access, S_Link_Nofiles 'Access, --- 1111,1122 ---- S_Link_ZZZZZ : aliased constant S := "/ " & "--for-linker="; ! Link_Switches : aliased constant Switches := ! (S_Link_Bind 'Access, S_Link_Debug 'Access, S_Link_Execut 'Access, S_Ext_Ref 'Access, + S_Link_Force 'Access, S_Link_Ident 'Access, S_Link_Nocomp 'Access, S_Link_Nofiles 'Access, *************** procedure GNATCmd is *** 969,977 **** S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " & "!-I-"; - S_List_Depend : aliased constant S := "/DEPENDENCIES " & - "-d"; - S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & "-nostdinc"; --- 1137,1142 ---- *************** procedure GNATCmd is *** 981,986 **** --- 1146,1153 ---- S_List_Output : aliased constant S := "/OUTPUT=" & "SOURCES " & "-s " & + "DEPEND " & + "-d " & "OBJECTS " & "-o " & "UNITS " & *************** procedure GNATCmd is *** 996,1013 **** S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; ! List_Switches : aliased constant Switches := ( ! S_List_All 'Access, ! S_List_Current 'Access, ! S_List_Depend 'Access, ! S_Ext_Ref 'Access, ! S_List_Nostinc 'Access, ! S_List_Object 'Access, ! S_List_Output 'Access, ! S_Project_File 'Access, ! S_Project_Verb 'Access, ! S_List_Search 'Access, ! S_List_Source 'Access); ---------------------------- -- Switches for GNAT MAKE -- --- 1163,1179 ---- S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; ! List_Switches : aliased constant Switches := ! (S_List_All 'Access, ! S_List_Current 'Access, ! S_Ext_Ref 'Access, ! S_List_Nostinc 'Access, ! S_List_Object 'Access, ! S_List_Output 'Access, ! S_Project_File 'Access, ! S_Project_Verb 'Access, ! S_List_Search 'Access, ! S_List_Source 'Access); ---------------------------- -- Switches for GNAT MAKE -- *************** procedure GNATCmd is *** 1015,1025 **** S_Make_Actions : aliased constant S := "/ACTIONS=" & "COMPILE " & ! "-c " & "BIND " & ! "-b " & "LINK " & ! "-l "; S_Make_All : aliased constant S := "/ALL_FILES " & "-a"; --- 1181,1191 ---- S_Make_Actions : aliased constant S := "/ACTIONS=" & "COMPILE " & ! "-c " & "BIND " & ! "-b " & "LINK " & ! "-l "; S_Make_All : aliased constant S := "/ALL_FILES " & "-a"; *************** procedure GNATCmd is *** 1052,1058 **** "-f"; S_Make_Inplace : aliased constant S := "/IN_PLACE " & ! "-i"; S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-L*"; --- 1218,1224 ---- "-f"; S_Make_Inplace : aliased constant S := "/IN_PLACE " & ! "-i"; S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-L*"; *************** procedure GNATCmd is *** 1060,1071 **** S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" & "-largs LINK"; S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " & ! "-m"; S_Make_Nolink : aliased constant S := "/NOLINK " & "-c"; S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & "-nostdinc"; --- 1226,1243 ---- S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" & "-largs LINK"; + S_Make_Mapping : aliased constant S := "/MAPPING " & + "-C"; + S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " & ! "-m"; S_Make_Nolink : aliased constant S := "/NOLINK " & "-c"; + S_Make_Nomain : aliased constant S := "/NOMAIN " & + "-z"; + S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & "-nostdinc"; *************** procedure GNATCmd is *** 1087,1092 **** --- 1259,1267 ---- S_Make_Reason : aliased constant S := "/REASONS " & "-v"; + S_Make_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & + "--RTS=|"; + S_Make_Search : aliased constant S := "/SEARCH=*" & "-I*"; *************** procedure GNATCmd is *** 1096,1140 **** S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; S_Make_Verbose : aliased constant S := "/VERBOSE " & "-v"; ! Make_Switches : aliased constant Switches := ( ! S_Make_Actions 'Access, ! S_Make_All 'Access, ! S_Make_Bind 'Access, ! S_Make_Comp 'Access, ! S_Make_Cond 'Access, ! S_Make_Cont 'Access, ! S_Make_Current 'Access, ! S_Make_Dep 'Access, ! S_Make_Doobj 'Access, ! S_Make_Execut 'Access, ! S_Ext_Ref 'Access, ! S_Make_Force 'Access, ! S_Make_Inplace 'Access, ! S_Make_Library 'Access, ! S_Make_Link 'Access, ! S_Make_Minimal 'Access, ! S_Make_Nolink 'Access, ! S_Make_Nostinc 'Access, ! S_Make_Nostlib 'Access, ! S_Make_Object 'Access, ! S_Make_Proc 'Access, ! S_Project_File 'Access, ! S_Project_Verb 'Access, ! S_Make_Nojobs 'Access, ! S_Make_Quiet 'Access, ! S_Make_Reason 'Access, ! S_Make_Search 'Access, ! S_Make_Skip 'Access, ! S_Make_Source 'Access, ! S_Make_Verbose 'Access); ---------------------------------- -- Switches for GNAT PREPROCESS -- ---------------------------------- S_Prep_Blank : aliased constant S := "/BLANK_LINES " & "-b"; --- 1271,1359 ---- S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; + S_Make_Switch : aliased constant S := "/SWITCH_CHECK " & + "-s"; + + S_Make_Unique : aliased constant S := "/UNIQUE " & + "-u"; + S_Make_Verbose : aliased constant S := "/VERBOSE " & "-v"; ! Make_Switches : aliased constant Switches := ! (S_Make_Actions 'Access, ! S_Make_All 'Access, ! S_Make_Bind 'Access, ! S_Make_Comp 'Access, ! S_Make_Cond 'Access, ! S_Make_Cont 'Access, ! S_Make_Current 'Access, ! S_Make_Dep 'Access, ! S_Make_Doobj 'Access, ! S_Make_Execut 'Access, ! S_Ext_Ref 'Access, ! S_Make_Force 'Access, ! S_Make_Inplace 'Access, ! S_Make_Library 'Access, ! S_Make_Link 'Access, ! S_Make_Mapping 'Access, ! S_Make_Minimal 'Access, ! S_Make_Nolink 'Access, ! S_Make_Nomain 'Access, ! S_Make_Nostinc 'Access, ! S_Make_Nostlib 'Access, ! S_Make_Object 'Access, ! S_Make_Proc 'Access, ! S_Project_File 'Access, ! S_Project_Verb 'Access, ! S_Make_Nojobs 'Access, ! S_Make_Quiet 'Access, ! S_Make_Reason 'Access, ! S_Make_RTS 'Access, ! S_Make_Search 'Access, ! S_Make_Skip 'Access, ! S_Make_Source 'Access, ! S_Make_Switch 'Access, ! S_Make_Unique 'Access, ! S_Make_Verbose 'Access); ! ! ---------------------------- ! -- Switches for GNAT Name -- ! ---------------------------- ! ! S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" & ! "-c>"; ! ! S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" & ! "-d*"; ! ! S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" & ! "-D>"; ! ! S_Name_Help : aliased constant S := "/HELP" & ! " -h"; ! ! S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" & ! "-P>"; ! ! S_Name_Verbose : aliased constant S := "/VERBOSE" & ! " -v"; ! ! Name_Switches : aliased constant Switches := ! (S_Name_Conf 'Access, ! S_Name_Dirs 'Access, ! S_Name_Dfile 'Access, ! S_Name_Help 'Access, ! S_Name_Proj 'Access, ! S_Name_Verbose 'Access); ---------------------------------- -- Switches for GNAT PREPROCESS -- ---------------------------------- + S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' & + "-D" & '"'; + S_Prep_Blank : aliased constant S := "/BLANK_LINES " & "-b"; *************** procedure GNATCmd is *** 1153,1173 **** S_Prep_Undef : aliased constant S := "/UNDEFINED " & "-u"; ! S_Prep_Verbose : aliased constant S := "/VERBOSE " & ! "-v"; ! ! S_Prep_Version : aliased constant S := "/VERSION " & ! "-v"; ! ! Prep_Switches : aliased constant Switches := ( ! S_Prep_Blank 'Access, ! S_Prep_Com 'Access, ! S_Prep_Ref 'Access, ! S_Prep_Remove 'Access, ! S_Prep_Symbols 'Access, ! S_Prep_Undef 'Access, ! S_Prep_Verbose 'Access, ! S_Prep_Version 'Access); ------------------------------ -- Switches for GNAT SHARED -- --- 1372,1385 ---- S_Prep_Undef : aliased constant S := "/UNDEFINED " & "-u"; ! Prep_Switches : aliased constant Switches := ! (S_Prep_Assoc 'Access, ! S_Prep_Blank 'Access, ! S_Prep_Com 'Access, ! S_Prep_Ref 'Access, ! S_Prep_Remove 'Access, ! S_Prep_Symbols 'Access, ! S_Prep_Undef 'Access); ------------------------------ -- Switches for GNAT SHARED -- *************** procedure GNATCmd is *** 1202,1209 **** S_Shared_ZZZZZ : aliased constant S := "/ " & "--for-linker="; ! Shared_Switches : aliased constant Switches := ( ! S_Shared_Debug 'Access, S_Shared_Image 'Access, S_Shared_Ident 'Access, S_Shared_Nofiles 'Access, --- 1414,1421 ---- S_Shared_ZZZZZ : aliased constant S := "/ " & "--for-linker="; ! Shared_Switches : aliased constant Switches := ! (S_Shared_Debug 'Access, S_Shared_Image 'Access, S_Shared_Ident 'Access, S_Shared_Nofiles 'Access, *************** procedure GNATCmd is *** 1256,1277 **** S_Stub_Verbose : aliased constant S := "/VERBOSE " & "-v"; ! Stub_Switches : aliased constant Switches := ( ! S_Stub_Current 'Access, ! S_Stub_Full 'Access, ! S_Stub_Header 'Access, ! S_Stub_Indent 'Access, ! S_Stub_Length 'Access, ! S_Stub_Quiet 'Access, ! S_Stub_Search 'Access, ! S_Stub_Tree 'Access, ! S_Stub_Verbose 'Access); ! ! ------------------------------ ! -- Switches for GNAT SYSTEM -- ! ------------------------------ ! ! System_Switches : aliased constant Switches := (1 .. 0 => null); ---------------------------- -- Switches for GNAT XREF -- --- 1468,1483 ---- S_Stub_Verbose : aliased constant S := "/VERBOSE " & "-v"; ! Stub_Switches : aliased constant Switches := ! (S_Stub_Current 'Access, ! S_Stub_Full 'Access, ! S_Stub_Header 'Access, ! S_Stub_Indent 'Access, ! S_Stub_Length 'Access, ! S_Stub_Quiet 'Access, ! S_Stub_Search 'Access, ! S_Stub_Tree 'Access, ! S_Stub_Verbose 'Access); ---------------------------- -- Switches for GNAT XREF -- *************** procedure GNATCmd is *** 1280,1291 **** --- 1486,1506 ---- S_Xref_All : aliased constant S := "/ALL_FILES " & "-a"; + S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " & + "-d"; + S_Xref_Full : aliased constant S := "/FULL_PATHNAME " & "-f"; S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " & "-g"; + S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" & "-aO*"; *************** procedure GNATCmd is *** 1301,1318 **** S_Xref_Output : aliased constant S := "/UNUSED " & "-u"; ! Xref_Switches : aliased constant Switches := ( ! S_Xref_All 'Access, S_Ext_Ref 'Access, S_Xref_Full 'Access, S_Xref_Global 'Access, S_Xref_Object 'Access, S_Xref_Project 'Access, S_Project_File 'Access, S_Project_Verb 'Access, S_Xref_Search 'Access, S_Xref_Source 'Access, ! S_Xref_Output 'Access); ------------------- -- COMMAND TABLE -- --- 1516,1540 ---- S_Xref_Output : aliased constant S := "/UNUSED " & "-u"; ! S_Xref_Tags : aliased constant S := "/TAGS " & ! "-v"; ! ! Xref_Switches : aliased constant Switches := ! (S_Xref_All 'Access, ! S_Xref_Deriv 'Access, S_Ext_Ref 'Access, S_Xref_Full 'Access, S_Xref_Global 'Access, + S_Xref_Nostinc 'Access, + S_Xref_Nostlib 'Access, S_Xref_Object 'Access, S_Xref_Project 'Access, S_Project_File 'Access, S_Project_Verb 'Access, S_Xref_Search 'Access, S_Xref_Source 'Access, ! S_Xref_Output 'Access, ! S_Xref_Tags 'Access); ------------------- -- COMMAND TABLE -- *************** procedure GNATCmd is *** 1334,1342 **** -- A parameter that's passed through as is (not canonicalized) Unlimited_Files, ! -- An unlimited number of writespace separate file or directory -- parameters including wildcard specifications. Files_Or_Wildcard); -- A comma separated list of files and/or wildcard file specifications. -- A comma preceded by or followed by whitespace is considered as a --- 1556,1568 ---- -- A parameter that's passed through as is (not canonicalized) Unlimited_Files, ! -- An unlimited number of whitespace separate file or directory -- parameters including wildcard specifications. + Unlimited_As_Is, + -- Un unlimited number of whitespace separated paameters that are + -- passed through as is (not canonicalized). + Files_Or_Wildcard); -- A comma separated list of files and/or wildcard file specifications. -- A comma preceded by or followed by whitespace is considered as a *************** procedure GNATCmd is *** 1345,1350 **** --- 1571,1593 ---- type Parameter_Array is array (Natural range <>) of Parameter_Type; type Parameter_Ref is access all Parameter_Array; + type Command_Type is + (Bind, Chop, Compile, Elim, Find, Krunch, Library, Link, List, + Make, Name, Preprocess, Shared, Standard, Stub, Xref, Undefined); + + type Alternate_Command is (Comp, Ls, Kr, Prep, Psta); + -- Alternate command libel for non VMS system + + Corresponding_To : constant array (Alternate_Command) of Command_Type := + (Comp => Compile, + Ls => List, + Kr => Krunch, + Prep => Preprocess, + Psta => Standard); + -- Mapping of alternate commands to commands + + subtype Real_Command_Type is Command_Type range Bind .. Xref; + type Command_Entry is record Cname : String_Ptr; -- Command name for GNAT xxx command *************** procedure GNATCmd is *** 1352,1360 **** Usage : String_Ptr; -- A usage string, used for error messages ! Unixcmd : String_Ptr; -- Corresponding Unix command Switches : Switches_Ptr; -- Pointer to array of switch strings --- 1595,1609 ---- Usage : String_Ptr; -- A usage string, used for error messages ! Unixcmd : String_Ptr; -- Corresponding Unix command + Unixsws : Argument_List_Access; + -- Switches for the Unix command + + VMS_Only : Boolean; + -- When True, the command can only be used on VMS + Switches : Switches_Ptr; -- Pointer to array of switch strings *************** procedure GNATCmd is *** 1398,1406 **** -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] T_File, ! -- A quailifier followed by a filename -- Example: GNAT LINK /EXECUTABLE=FOO.EXE T_Numeric, -- A qualifier followed by a numeric value. -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 --- 1647,1659 ---- -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] T_File, ! -- A qualifier followed by a filename -- Example: GNAT LINK /EXECUTABLE=FOO.EXE + T_No_Space_File, + -- A qualifier followed by a filename + -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR + T_Numeric, -- A qualifier followed by a numeric value. -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 *************** procedure GNATCmd is *** 1429,1435 **** -- A qualifier followed by a legal linker symbol prefix. Only used -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). -- Example: GNAT BIND /BUILD_LIBRARY=foobar ! ); type Item (Id : Item_Id); type Item_Ptr is access all Item; --- 1682,1688 ---- -- A qualifier followed by a legal linker symbol prefix. Only used -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). -- Example: GNAT BIND /BUILD_LIBRARY=foobar ! ); type Item (Id : Item_Id); type Item_Ptr is access all Item; *************** procedure GNATCmd is *** 1441,1447 **** Next : Item_Ptr; -- Pointer to next item on list, always has the same Id value ! Unix_String : String_Ptr; -- Corresponding Unix string. For a command, this is the unix command -- name and possible default switches. For a switch or option it is -- the unix switch string. --- 1694,1702 ---- Next : Item_Ptr; -- Pointer to next item on list, always has the same Id value ! Command : Command_Type := Undefined; ! ! Unix_String : String_Ptr := null; -- Corresponding Unix string. For a command, this is the unix command -- name and possible default switches. For a switch or option it is -- the unix switch string. *************** procedure GNATCmd is *** 1511,1516 **** --- 1766,1773 ---- Errors : Natural := 0; -- Count errors detected + Command_Arg : Positive := 1; + Command : Item_Ptr; -- Pointer to command item for current command *************** procedure GNATCmd is *** 1521,1533 **** My_Exit_Status : Exit_Status := Success; ! package Buffer is new Table.Table ( ! Table_Component_Type => Character, ! Table_Index_Type => Integer, ! Table_Low_Bound => 1, ! Table_Initial => 4096, ! Table_Increment => 2, ! Table_Name => "Buffer"); Param_Count : Natural := 0; -- Number of parameter arguments so far --- 1778,1790 ---- My_Exit_Status : Exit_Status := Success; ! package Buffer is new Table.Table ! (Table_Component_Type => Character, ! Table_Index_Type => Integer, ! Table_Low_Bound => 1, ! Table_Initial => 4096, ! Table_Increment => 2, ! Table_Name => "Buffer"); Param_Count : Natural := 0; -- Number of parameter arguments so far *************** procedure GNATCmd is *** 1536,1548 **** -- Argument number Display_Command : Boolean := False; ! -- Set true if /? switch causes display of generated command ----------------------- -- Local Subprograms -- ----------------------- ! function Init_Object_Dirs return String_Ptr; function Invert_Sense (S : String) return String_Ptr; -- Given a unix switch string S, computes the inverse (adding or --- 1793,1812 ---- -- Argument number Display_Command : Boolean := False; ! -- Set true if /? switch causes display of generated command (on VMS) ! ! The_Command : Command_Type; ! -- The command used ----------------------- -- Local Subprograms -- ----------------------- ! function Index (Char : Character; Str : String) return Natural; ! -- Returns the first occurrence of Char in Str. ! -- Returns 0 if Char is not in Str. ! ! function Init_Object_Dirs return Argument_List; function Invert_Sense (S : String) return String_Ptr; -- Given a unix switch string S, computes the inverse (adding or *************** procedure GNATCmd is *** 1575,1580 **** --- 1839,1847 ---- -- error message is generated in a not found situation (null is still -- returned to indicate the not-found situation). + procedure Non_VMS_Usage; + -- Display usage for platforms other than VMS + function OK_Alphanumerplus (S : String) return Boolean; -- Checks that S is a string of alphanumeric characters, -- returning True if all alphanumeric characters, *************** procedure GNATCmd is *** 1584,1589 **** --- 1851,1859 ---- -- Checks that S is a string of digits, returning True if all digits, -- False if empty or a non-digit is present. + procedure Output_Version; + -- Output the version of this program + procedure Place (C : Character); -- Place a single character in the buffer, updating Ptr *************** procedure GNATCmd is *** 1598,1603 **** --- 1868,1884 ---- -- updating Ptr appropriatelly. Note that in the case of use of ! the -- result may be to remove a previously placed switch. + procedure Set_Library_For + (Project : Project_Id; + There_Are_Libraries : in out Boolean); + -- If Project is a library project, add the correct + -- -L and -l switches to the linker invocation. + + procedure Set_Libraries is + new For_Every_Project_Imported (Boolean, Set_Library_For); + -- Add the -L and -l switches to the linker for all + -- of the library projects. + procedure Validate_Command_Or_Option (N : String_Ptr); -- Check that N is a valid command or option name, i.e. that it is of the -- form of an Ada identifier with upper case letters and underscores. *************** procedure GNATCmd is *** 1606,1618 **** -- Check that S is a valid switch string as described in the syntax for -- the switch table item UNIX_SWITCH or else begins with a backquote. ---------------------- -- Init_Object_Dirs -- ---------------------- ! function Init_Object_Dirs return String_Ptr is Object_Dirs : Integer; ! Object_Dir : array (Integer range 1 .. 256) of String_Access; Object_Dir_Name : String_Access; begin --- 1887,1917 ---- -- Check that S is a valid switch string as described in the syntax for -- the switch table item UNIX_SWITCH or else begins with a backquote. + procedure VMS_Conversion (The_Command : out Command_Type); + -- Converts VMS command line to equivalent Unix command line + + ----------- + -- Index -- + ----------- + + function Index (Char : Character; Str : String) return Natural is + begin + for Index in Str'Range loop + if Str (Index) = Char then + return Index; + end if; + end loop; + + return 0; + end Index; + ---------------------- -- Init_Object_Dirs -- ---------------------- ! function Init_Object_Dirs return Argument_List is Object_Dirs : Integer; ! Object_Dir : Argument_List (1 .. 256); Object_Dir_Name : String_Access; begin *************** procedure GNATCmd is *** 1627,1692 **** begin exit when Dir = null; Object_Dirs := Object_Dirs + 1; ! Object_Dir (Object_Dirs) ! := String_Access (Normalize_Directory_Name (Dir.all)); end; end loop; ! for Dirs in 1 .. Object_Dirs loop ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := '-'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'L'; ! Object_Dir_Name := new String'( ! To_Canonical_Dir_Spec ! (To_Host_Dir_Spec (Object_Dir (Dirs).all, True).all, True).all); ! ! for J in Object_Dir_Name'Range loop ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := Object_Dir_Name (J); ! end loop; ! ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := ' '; ! end loop; ! ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := '-'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'l'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'g'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'n'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'a'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 't'; if Hostparm.OpenVMS then ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := ' '; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := '-'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'l'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'd'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'e'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'c'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'g'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'n'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 'a'; ! Buffer.Increment_Last; ! Buffer.Table (Buffer.Last) := 't'; end if; ! return new String'(String (Buffer.Table (1 .. Buffer.Last))); end Init_Object_Dirs; ------------------ --- 1926,1949 ---- begin exit when Dir = null; Object_Dirs := Object_Dirs + 1; ! Object_Dir (Object_Dirs) := ! new String'("-L" & ! To_Canonical_Dir_Spec ! (To_Host_Dir_Spec ! (Normalize_Directory_Name (Dir.all).all, ! True).all, True).all); end; end loop; ! Object_Dirs := Object_Dirs + 1; ! Object_Dir (Object_Dirs) := new String'("-lgnat"); if Hostparm.OpenVMS then ! Object_Dirs := Object_Dirs + 1; ! Object_Dir (Object_Dirs) := new String'("-ldecgnat"); end if; ! return Object_Dir (1 .. Object_Dirs); end Init_Object_Dirs; ------------------ *************** procedure GNATCmd is *** 1781,1787 **** (S : String; Itm : Item_Ptr; Quiet : Boolean := False) ! return Item_Ptr is P1, P2 : Item_Ptr; --- 2038,2044 ---- (S : String; Itm : Item_Ptr; Quiet : Boolean := False) ! return Item_Ptr is P1, P2 : Item_Ptr; *************** procedure GNATCmd is *** 1789,1794 **** --- 2046,2055 ---- -- Little procedure to output command/qualifier/option as appropriate -- and bump error count. + --------- + -- Err -- + --------- + procedure Err is begin if Quiet then *************** procedure GNATCmd is *** 1820,1826 **** Put (Standard_Error, ": "); Put (Standard_Error, S); - end Err; -- Start of processing for Matching_Name --- 2081,2086 ---- *************** procedure GNATCmd is *** 1937,1942 **** --- 2197,2213 ---- end if; end OK_Integer; + -------------------- + -- Output_Version -- + -------------------- + + procedure Output_Version is + begin + Put ("GNAT "); + Put (Gnatvsn.Gnat_Version_String); + Put_Line (" Copyright 1996-2002 Free Software Foundation, Inc."); + end Output_Version; + ----------- -- Place -- ----------- *************** procedure GNATCmd is *** 1945,1950 **** --- 2216,2226 ---- begin Buffer.Increment_Last; Buffer.Table (Buffer.Last) := C; + + -- Do not put a space as the first character in the buffer + if C = ' ' and then Buffer.Last = 1 then + Buffer.Decrement_Last; + end if; end Place; procedure Place (S : String) is *************** procedure GNATCmd is *** 1999,2006 **** P3 := 2; while P3 <= Buffer.Last - Slen loop if Buffer.Table (P3) = ' ' ! and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) ! = S (P1 .. P2) and then (P3 + Slen = Buffer.Last or else Buffer.Table (P3 + Slen + 1) = ' ') --- 2275,2282 ---- P3 := 2; while P3 <= Buffer.Last - Slen loop if Buffer.Table (P3) = ' ' ! and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) = ! S (P1 .. P2) and then (P3 + Slen = Buffer.Last or else Buffer.Table (P3 + Slen + 1) = ' ') *************** procedure GNATCmd is *** 2028,2033 **** --- 2304,2362 ---- end loop; end Place_Unix_Switches; + --------------------- + -- Set_Library_For -- + --------------------- + + procedure Set_Library_For + (Project : Project_Id; + There_Are_Libraries : in out Boolean) + is + begin + -- Case of library project + + if Projects.Table (Project).Library then + There_Are_Libraries := True; + + -- Add the -L switch + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-L" & + Get_Name_String + (Projects.Table (Project).Library_Dir)); + + -- Add the -l switch + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-l" & + Get_Name_String + (Projects.Table (Project).Library_Name)); + + -- Add the Wl,-rpath switch if library non static + + if Projects.Table (Project).Library_Kind /= Static then + declare + Option : constant String_Access := + MLib.Tgt.Linker_Library_Path_Option + (Get_Name_String + (Projects.Table (Project).Library_Dir)); + + begin + if Option /= null then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + Option; + end if; + + end; + + end if; + + end if; + end Set_Library_For; + -------------------------------- -- Validate_Command_Or_Option -- -------------------------------- *************** procedure GNATCmd is *** 2073,2792 **** -- List of Commands -- ---------------------- ! -- Note that we put this after all the local bodies to avoid ! -- some access before elaboration problems. ! Command_List : array (Natural range <>) of Command_Entry := ( ! (Cname => new S'("BIND"), ! Usage => new S'("GNAT BIND file[.ali] /qualifiers"), ! Unixcmd => new S'("gnatbind"), ! Switches => Bind_Switches'Access, ! Params => new Parameter_Array'(1 => File), ! Defext => "ali"), ! (Cname => new S'("CHOP"), ! Usage => new S'("GNAT CHOP file [directory] /qualifiers"), ! Unixcmd => new S'("gnatchop"), ! Switches => Chop_Switches'Access, ! Params => new Parameter_Array'(1 => File, 2 => Optional_File), ! Defext => " "), ! (Cname => new S'("COMPILE"), ! Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), ! Unixcmd => new S'("gcc -c -x ada"), ! Switches => GCC_Switches'Access, ! Params => new Parameter_Array'(1 => Files_Or_Wildcard), ! Defext => " "), ! (Cname => new S'("ELIM"), ! Usage => new S'("GNAT ELIM name /qualifiers"), ! Unixcmd => new S'("gnatelim"), ! Switches => Elim_Switches'Access, ! Params => new Parameter_Array'(1 => Other_As_Is), ! Defext => "ali"), ! (Cname => new S'("FIND"), ! Usage => new S'("GNAT FIND pattern[:sourcefile[:line[:column]]]" & ! " filespec[,...] /qualifiers"), ! Unixcmd => new S'("gnatfind"), ! Switches => Find_Switches'Access, ! Params => new Parameter_Array'(1 => Other_As_Is, ! 2 => Files_Or_Wildcard), ! Defext => "ali"), ! (Cname => new S'("KRUNCH"), ! Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), ! Unixcmd => new S'("gnatkr"), ! Switches => Krunch_Switches'Access, ! Params => new Parameter_Array'(1 => File), ! Defext => " "), ! (Cname => new S'("LIBRARY"), ! Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]=directory" ! & " [/CONFIG=file]"), ! Unixcmd => new S'("gnatlbr"), ! Switches => Lbr_Switches'Access, ! Params => new Parameter_Array'(1 .. 0 => File), ! Defext => " "), ! (Cname => new S'("LINK"), ! Usage => new S'("GNAT LINK file[.ali]" ! & " [extra obj_&_lib_&_exe_&_opt files]" ! & " /qualifiers"), ! Unixcmd => new S'("gnatlink"), ! Switches => Link_Switches'Access, ! Params => new Parameter_Array'(1 => Unlimited_Files), ! Defext => "ali"), ! (Cname => new S'("LIST"), ! Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), ! Unixcmd => new S'("gnatls"), ! Switches => List_Switches'Access, ! Params => new Parameter_Array'(1 => File), ! Defext => "ali"), ! (Cname => new S'("MAKE"), ! Usage => ! new S'("GNAT MAKE file /qualifiers (includes COMPILE /qualifiers)"), ! Unixcmd => new S'("gnatmake"), ! Switches => Make_Switches'Access, ! Params => new Parameter_Array'(1 => File), ! Defext => " "), ! (Cname => new S'("PREPROCESS"), ! Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), ! Unixcmd => new S'("gnatprep"), ! Switches => Prep_Switches'Access, ! Params => new Parameter_Array'(1 .. 3 => File), ! Defext => " "), ! (Cname => new S'("SHARED"), ! Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt files]" ! & " /qualifiers"), ! Unixcmd => new S'("gcc -shared " & Init_Object_Dirs.all), ! Switches => Shared_Switches'Access, ! Params => new Parameter_Array'(1 => Unlimited_Files), ! Defext => " "), ! (Cname => new S'("STANDARD"), ! Usage => new S'("GNAT STANDARD"), ! Unixcmd => new S'("gnatpsta"), ! Switches => Standard_Switches'Access, ! Params => new Parameter_Array'(1 .. 0 => File), ! Defext => " "), ! (Cname => new S'("STUB"), ! Usage => new S'("GNAT STUB file [directory] /qualifiers"), ! Unixcmd => new S'("gnatstub"), ! Switches => Stub_Switches'Access, ! Params => new Parameter_Array'(1 => File, 2 => Optional_File), ! Defext => " "), ! (Cname => new S'("SYSTEM"), ! Usage => new S'("GNAT SYSTEM"), ! Unixcmd => new S'("gnatpsys"), ! Switches => System_Switches'Access, ! Params => new Parameter_Array'(1 .. 0 => File), ! Defext => " "), ! (Cname => new S'("XREF"), ! Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), ! Unixcmd => new S'("gnatxref"), ! Switches => Xref_Switches'Access, ! Params => new Parameter_Array'(1 => Files_Or_Wildcard), ! Defext => "ali") ! ); ! ------------------------------------- ! -- Start of processing for GNATCmd -- ! ------------------------------------- ! begin ! Buffer.Init; ! -- First we must preprocess the string form of the command and options ! -- list into the internal form that we use. ! for C in Command_List'Range loop ! declare ! Command : Item_Ptr := new Command_Item; ! Last_Switch : Item_Ptr; ! -- Last switch in list ! begin ! -- Link new command item into list of commands ! if Last_Command = null then ! Commands := Command; ! else ! Last_Command.Next := Command; ! end if; ! Last_Command := Command; ! -- Fill in fields of new command item ! Command.Name := Command_List (C).Cname; ! Command.Usage := Command_List (C).Usage; ! Command.Unix_String := Command_List (C).Unixcmd; ! Command.Params := Command_List (C).Params; ! Command.Defext := Command_List (C).Defext; ! Validate_Command_Or_Option (Command.Name); ! -- Process the switch list ! for S in Command_List (C).Switches'Range loop ! declare ! SS : constant String_Ptr := Command_List (C).Switches (S); ! P : Natural := SS'First; ! Sw : Item_Ptr := new Switch_Item; ! Last_Opt : Item_Ptr; ! -- Pointer to last option ! begin ! -- Link new switch item into list of switches ! if Last_Switch = null then ! Command.Switches := Sw; ! else ! Last_Switch.Next := Sw; ! end if; ! Last_Switch := Sw; ! -- Process switch string, first get name ! while SS (P) /= ' ' and SS (P) /= '=' loop ! P := P + 1; ! end loop; ! Sw.Name := new String'(SS (SS'First .. P - 1)); ! -- Direct translation case ! if SS (P) = ' ' then ! Sw.Translation := T_Direct; ! Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); ! Validate_Unix_Switch (Sw.Unix_String); ! if SS (P - 1) = '>' then ! Sw.Translation := T_Other; ! elsif SS (P + 1) = '`' then ! null; ! -- Create the inverted case (/NO ..) ! elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then ! Sw := new Switch_Item; Last_Switch.Next := Sw; - Last_Switch := Sw; - - Sw.Name := - new String'("/NO" & SS (SS'First + 1 .. P - 1)); - Sw.Translation := T_Direct; - Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); - Validate_Unix_Switch (Sw.Unix_String); end if; ! -- Directories translation case ! ! elsif SS (P + 1) = '*' then ! pragma Assert (SS (SS'Last) = '*'); ! Sw.Translation := T_Directories; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! ! -- Directory translation case ! ! elsif SS (P + 1) = '%' then ! pragma Assert (SS (SS'Last) = '%'); ! Sw.Translation := T_Directory; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! ! -- File translation case ! elsif SS (P + 1) = '@' then ! pragma Assert (SS (SS'Last) = '@'); ! Sw.Translation := T_File; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- Numeric translation case ! elsif SS (P + 1) = '#' then ! pragma Assert (SS (SS'Last) = '#'); ! Sw.Translation := T_Numeric; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- Alphanumerplus translation case ! elsif SS (P + 1) = '|' then ! pragma Assert (SS (SS'Last) = '|'); ! Sw.Translation := T_Alphanumplus; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- String translation case ! elsif SS (P + 1) = '"' then ! pragma Assert (SS (SS'Last) = '"'); ! Sw.Translation := T_String; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- Commands translation case ! elsif SS (P + 1) = '?' then ! Sw.Translation := T_Commands; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); ! -- Options translation case ! else ! Sw.Translation := T_Options; ! Sw.Unix_String := new String'(""); ! P := P + 1; -- bump past = ! while P <= SS'Last loop ! declare ! Opt : Item_Ptr := new Option_Item; ! Q : Natural; ! begin ! -- Link new option item into options list ! if Last_Opt = null then ! Sw.Options := Opt; ! else ! Last_Opt.Next := Opt; ! end if; ! Last_Opt := Opt; ! -- Fill in fields of new option item ! Q := P; ! while SS (Q) /= ' ' loop ! Q := Q + 1; ! end loop; ! Opt.Name := new String'(SS (P .. Q - 1)); ! Validate_Command_Or_Option (Opt.Name); ! P := Q + 1; ! Q := P; ! while Q <= SS'Last and then SS (Q) /= ' ' loop ! Q := Q + 1; ! end loop; ! Opt.Unix_String := new String'(SS (P .. Q - 1)); ! Validate_Unix_Switch (Opt.Unix_String); ! P := Q + 1; ! end; ! end loop; ! end if; ! end; ! end loop; ! end; ! end loop; ! -- If no parameters, give complete list of commands ! if Argument_Count = 0 then ! Put_Line ("List of available commands"); ! New_Line; ! while Commands /= null loop ! Put (Commands.Usage.all); ! Set_Col (53); ! Put_Line (Commands.Unix_String.all); ! Commands := Commands.Next; ! end loop; ! raise Normal_Exit; ! end if; ! Arg_Num := 1; ! loop ! exit when Arg_Num > Argument_Count; ! declare ! Argv : String_Access; ! Arg_Idx : Integer; ! function Get_Arg_End ! (Argv : String; ! Arg_Idx : Integer) ! return Integer; ! -- Begins looking at Arg_Idx + 1 and returns the index of the ! -- last character before a slash or else the index of the last ! -- character in the string Argv. ! function Get_Arg_End ! (Argv : String; ! Arg_Idx : Integer) ! return Integer ! is ! begin ! for J in Arg_Idx + 1 .. Argv'Last loop ! if Argv (J) = '/' then ! return J - 1; ! end if; ! end loop; ! return Argv'Last; ! end Get_Arg_End; ! begin ! Argv := new String'(Argument (Arg_Num)); ! Arg_Idx := Argv'First; ! <> ! loop ! declare ! Next_Arg_Idx : Integer; ! Arg : String_Access; ! begin ! Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); ! Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); ! -- The first one must be a command name ! if Arg_Num = 1 and then Arg_Idx = Argv'First then ! Command := Matching_Name (Arg.all, Commands); ! if Command = null then ! raise Error_Exit; end if; ! -- Give usage information if only command given ! if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last ! and then ! not (Command.Name.all = "SYSTEM" ! or else Command.Name.all = "STANDARD") ! then ! Put_Line ("List of available qualifiers and options"); ! New_Line; ! Put (Command.Usage.all); ! Set_Col (53); ! Put_Line (Command.Unix_String.all); ! declare ! Sw : Item_Ptr := Command.Switches; ! begin ! while Sw /= null loop ! Put (" "); ! Put (Sw.Name.all); ! case Sw.Translation is ! when T_Other => ! Set_Col (53); ! Put_Line (Sw.Unix_String.all & "/"); ! when T_Direct => ! Set_Col (53); ! Put_Line (Sw.Unix_String.all); ! when T_Directories => ! Put ("=(direc,direc,..direc)"); ! Set_Col (53); ! Put (Sw.Unix_String.all); ! Put (" direc "); ! Put (Sw.Unix_String.all); ! Put_Line (" direc ..."); ! when T_Directory => ! Put ("=directory"); ! Set_Col (53); ! Put (Sw.Unix_String.all); ! if Sw.Unix_String (Sw.Unix_String'Last) ! /= '=' ! then ! Put (' '); ! end if; ! Put_Line ("directory "); ! when T_File => ! Put ("=file"); ! Set_Col (53); ! Put (Sw.Unix_String.all); ! if Sw.Unix_String (Sw.Unix_String'Last) ! /= '=' ! then ! Put (' '); ! end if; ! Put_Line ("file "); ! when T_Numeric => ! Put ("=nnn"); ! Set_Col (53); ! if Sw.Unix_String (Sw.Unix_String'First) ! = '`' ! then ! Put (Sw.Unix_String ! (Sw.Unix_String'First + 1 ! .. Sw.Unix_String'Last)); ! else ! Put (Sw.Unix_String.all); ! end if; ! Put_Line ("nnn"); ! when T_Alphanumplus => ! Put ("=xyz"); ! Set_Col (53); ! if Sw.Unix_String (Sw.Unix_String'First) ! = '`' ! then ! Put (Sw.Unix_String ! (Sw.Unix_String'First + 1 ! .. Sw.Unix_String'Last)); ! else ! Put (Sw.Unix_String.all); ! end if; ! Put_Line ("xyz"); ! when T_String => ! Put ("="); ! Put ('"'); ! Put (""); ! Put ('"'); ! Set_Col (53); ! Put (Sw.Unix_String.all); ! if Sw.Unix_String (Sw.Unix_String'Last) ! /= '=' ! then ! Put (' '); ! end if; ! Put (""); ! New_Line; ! when T_Commands => ! Put (" (switches for "); ! Put (Sw.Unix_String ( ! Sw.Unix_String'First + 7 ! .. Sw.Unix_String'Last)); ! Put (')'); ! Set_Col (53); ! Put (Sw.Unix_String ( ! Sw.Unix_String'First ! .. Sw.Unix_String'First + 5)); ! Put_Line (" switches"); ! when T_Options => ! declare ! Opt : Item_Ptr := Sw.Options; ! begin ! Put_Line ("=(option,option..)"); ! while Opt /= null loop ! Put (" "); ! Put (Opt.Name.all); ! if Opt = Sw.Options then ! Put (" (D)"); ! end if; Set_Col (53); ! Put_Line (Opt.Unix_String.all); ! Opt := Opt.Next; ! end loop; ! end; ! end case; ! Sw := Sw.Next; ! end loop; ! end; ! raise Normal_Exit; ! end if; ! Place (Command.Unix_String.all); ! -- Special handling for internal debugging switch /? ! elsif Arg.all = "/?" then ! Display_Command := True; ! -- Copy -switch unchanged ! elsif Arg (Arg'First) = '-' then ! Place (' '); ! Place (Arg.all); ! -- Copy quoted switch with quotes stripped ! elsif Arg (Arg'First) = '"' then ! if Arg (Arg'Last) /= '"' then ! Put (Standard_Error, "misquoted argument: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! else ! Put (Arg (Arg'First + 1 .. Arg'Last - 1)); ! end if; ! -- Parameter Argument ! elsif Arg (Arg'First) /= '/' ! and then Make_Commands_Active = null ! then ! Param_Count := Param_Count + 1; ! if Param_Count <= Command.Params'Length then ! case Command.Params (Param_Count) is ! when File | Optional_File => ! declare ! Normal_File : String_Access ! := To_Canonical_File_Spec (Arg.all); ! begin ! Place (' '); ! Place_Lower (Normal_File.all); ! if Is_Extensionless (Normal_File.all) ! and then Command.Defext /= " " ! then ! Place ('.'); ! Place (Command.Defext); ! end if; ! end; ! when Unlimited_Files => ! declare ! Normal_File : String_Access ! := To_Canonical_File_Spec (Arg.all); ! File_Is_Wild : Boolean := False; ! File_List : String_Access_List_Access; ! begin ! for I in Arg'Range loop ! if Arg (I) = '*' ! or else Arg (I) = '%' ! then ! File_Is_Wild := True; ! end if; ! end loop; ! if File_Is_Wild then ! File_List := To_Canonical_File_List ! (Arg.all, False); ! for I in File_List.all'Range loop ! Place (' '); ! Place_Lower (File_List.all (I).all); ! end loop; ! else ! Place (' '); ! Place_Lower (Normal_File.all); ! if Is_Extensionless (Normal_File.all) ! and then Command.Defext /= " " ! then ! Place ('.'); ! Place (Command.Defext); ! end if; ! end if; ! Param_Count := Param_Count - 1; end; ! when Other_As_Is => ! Place (' '); ! Place (Arg.all); ! when Files_Or_Wildcard => ! -- Remove spaces from a comma separated list ! -- of file names and adjust control variables ! -- accordingly. ! while Arg_Num < Argument_Count and then ! (Argv (Argv'Last) = ',' xor ! Argument (Arg_Num + 1) ! (Argument (Arg_Num + 1)'First) = ',') ! loop ! Argv := new String'(Argv.all ! & Argument (Arg_Num + 1)); ! Arg_Num := Arg_Num + 1; ! Arg_Idx := Argv'First; ! Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); ! Arg := ! new String'(Argv (Arg_Idx .. Next_Arg_Idx)); ! end loop; ! -- Parse the comma separated list of VMS filenames ! -- and place them on the command line as space ! -- separated Unix style filenames. Lower case and ! -- add default extension as appropriate. ! declare ! Arg1_Idx : Integer := Arg'First; ! function Get_Arg1_End ! (Arg : String; Arg_Idx : Integer) ! return Integer; ! -- Begins looking at Arg_Idx + 1 and ! -- returns the index of the last character ! -- before a comma or else the index of the ! -- last character in the string Arg. ! function Get_Arg1_End ! (Arg : String; Arg_Idx : Integer) ! return Integer ! is ! begin ! for I in Arg_Idx + 1 .. Arg'Last loop ! if Arg (I) = ',' then ! return I - 1; ! end if; ! end loop; ! return Arg'Last; ! end Get_Arg1_End; ! begin ! loop ! declare ! Next_Arg1_Idx : Integer ! := Get_Arg1_End (Arg.all, Arg1_Idx); ! Arg1 : String ! := Arg (Arg1_Idx .. Next_Arg1_Idx); ! Normal_File : String_Access ! := To_Canonical_File_Spec (Arg1); begin Place (' '); Place_Lower (Normal_File.all); --- 2402,3145 ---- -- List of Commands -- ---------------------- ! -- Note that we put this after all the local bodies (except Non_VMS_Usage ! -- and VMS_Conversion that use Command_List) to avoid some access before ! -- elaboration problems. ! Command_List : constant array (Real_Command_Type) of Command_Entry := ! (Bind => ! (Cname => new S'("BIND"), ! Usage => new S'("GNAT BIND file[.ali] /qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatbind"), ! Unixsws => null, ! Switches => Bind_Switches'Access, ! Params => new Parameter_Array'(1 => File), ! Defext => "ali"), ! Chop => ! (Cname => new S'("CHOP"), ! Usage => new S'("GNAT CHOP file [directory] /qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatchop"), ! Unixsws => null, ! Switches => Chop_Switches'Access, ! Params => new Parameter_Array'(1 => File, 2 => Optional_File), ! Defext => " "), ! Compile => ! (Cname => new S'("COMPILE"), ! Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatmake"), ! Unixsws => new Argument_List' (1 => new String'("-f"), ! 2 => new String'("-u"), ! 3 => new String'("-c")), ! Switches => GCC_Switches'Access, ! Params => new Parameter_Array'(1 => Files_Or_Wildcard), ! Defext => " "), ! Elim => ! (Cname => new S'("ELIM"), ! Usage => new S'("GNAT ELIM name /qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatelim"), ! Unixsws => null, ! Switches => Elim_Switches'Access, ! Params => new Parameter_Array'(1 => Other_As_Is), ! Defext => "ali"), ! Find => ! (Cname => new S'("FIND"), ! Usage => new S'("GNAT FIND pattern[:sourcefile[:line" ! & "[:column]]] filespec[,...] /qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatfind"), ! Unixsws => null, ! Switches => Find_Switches'Access, ! Params => new Parameter_Array'(1 => Other_As_Is, ! 2 => Files_Or_Wildcard), ! Defext => "ali"), ! Krunch => ! (Cname => new S'("KRUNCH"), ! Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), ! VMS_Only => False, ! Unixcmd => new S'("gnatkr"), ! Unixsws => null, ! Switches => Krunch_Switches'Access, ! Params => new Parameter_Array'(1 => File), ! Defext => " "), ! Library => ! (Cname => new S'("LIBRARY"), ! Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]" ! & "=directory [/CONFIG=file]"), ! VMS_Only => True, ! Unixcmd => new S'("gnatlbr"), ! Unixsws => null, ! Switches => Lbr_Switches'Access, ! Params => new Parameter_Array'(1 .. 0 => File), ! Defext => " "), ! Link => ! (Cname => new S'("LINK"), ! Usage => new S'("GNAT LINK file[.ali]" ! & " [extra obj_&_lib_&_exe_&_opt files]" ! & " /qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatlink"), ! Unixsws => null, ! Switches => Link_Switches'Access, ! Params => new Parameter_Array'(1 => Unlimited_Files), ! Defext => "ali"), ! List => ! (Cname => new S'("LIST"), ! Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), ! VMS_Only => False, ! Unixcmd => new S'("gnatls"), ! Unixsws => null, ! Switches => List_Switches'Access, ! Params => new Parameter_Array'(1 => File), ! Defext => "ali"), ! Make => ! (Cname => new S'("MAKE"), ! Usage => new S'("GNAT MAKE file /qualifiers (includes " ! & "COMPILE /qualifiers)"), ! VMS_Only => False, ! Unixcmd => new S'("gnatmake"), ! Unixsws => null, ! Switches => Make_Switches'Access, ! Params => new Parameter_Array'(1 => File), ! Defext => " "), ! Name => ! (Cname => new S'("NAME"), ! Usage => new S'("GNAT NAME /qualifiers naming-pattern " ! & "[naming-patterns]"), ! VMS_Only => False, ! Unixcmd => new S'("gnatname"), ! Unixsws => null, ! Switches => Name_Switches'Access, ! Params => new Parameter_Array'(1 => Unlimited_As_Is), ! Defext => " "), ! Preprocess => ! (Cname => new S'("PREPROCESS"), ! Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatprep"), ! Unixsws => null, ! Switches => Prep_Switches'Access, ! Params => new Parameter_Array'(1 .. 3 => File), ! Defext => " "), ! Shared => ! (Cname => new S'("SHARED"), ! Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" ! & "files] /qualifiers"), ! VMS_Only => True, ! Unixcmd => new S'("gcc"), ! Unixsws => new Argument_List'(new String'("-shared") ! & Init_Object_Dirs), ! Switches => Shared_Switches'Access, ! Params => new Parameter_Array'(1 => Unlimited_Files), ! Defext => " "), ! Standard => ! (Cname => new S'("STANDARD"), ! Usage => new S'("GNAT STANDARD"), ! VMS_Only => False, ! Unixcmd => new S'("gnatpsta"), ! Unixsws => null, ! Switches => Standard_Switches'Access, ! Params => new Parameter_Array'(1 .. 0 => File), ! Defext => " "), ! Stub => ! (Cname => new S'("STUB"), ! Usage => new S'("GNAT STUB file [directory]/qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatstub"), ! Unixsws => null, ! Switches => Stub_Switches'Access, ! Params => new Parameter_Array'(1 => File, 2 => Optional_File), ! Defext => " "), ! Xref => ! (Cname => new S'("XREF"), ! Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), ! VMS_Only => False, ! Unixcmd => new S'("gnatxref"), ! Unixsws => null, ! Switches => Xref_Switches'Access, ! Params => new Parameter_Array'(1 => Files_Or_Wildcard), ! Defext => "ali") ! ); ! ------------------- ! -- Non_VMS_Usage -- ! ------------------- ! procedure Non_VMS_Usage is ! begin ! Output_Version; ! New_Line; ! Put_Line ("List of available commands"); ! New_Line; ! for C in Command_List'Range loop ! if not Command_List (C).VMS_Only then ! Put ("GNAT " & Command_List (C).Cname.all); ! Set_Col (25); ! Put (Command_List (C).Unixcmd.all); ! declare ! Sws : Argument_List_Access renames Command_List (C).Unixsws; ! begin ! if Sws /= null then ! for J in Sws'Range loop ! Put (' '); ! Put (Sws (J).all); ! end loop; ! end if; ! end; ! New_Line; ! end if; ! end loop; ! New_Line; ! Put_Line ("Commands FIND, LIST and XREF accept project file " & ! "switches -vPx, -Pprj and -Xnam=val"); ! New_Line; ! end Non_VMS_Usage; ! -------------------- ! -- VMS_Conversion -- ! -------------------- ! procedure VMS_Conversion (The_Command : out Command_Type) is ! begin ! Buffer.Init; ! -- First we must preprocess the string form of the command and options ! -- list into the internal form that we use. ! for C in Real_Command_Type loop ! declare ! Command : Item_Ptr := new Command_Item; ! Last_Switch : Item_Ptr; ! -- Last switch in list ! begin ! -- Link new command item into list of commands ! if Last_Command = null then ! Commands := Command; ! else ! Last_Command.Next := Command; ! end if; ! Last_Command := Command; ! -- Fill in fields of new command item ! Command.Name := Command_List (C).Cname; ! Command.Usage := Command_List (C).Usage; ! Command.Command := C; ! if Command_List (C).Unixsws = null then ! Command.Unix_String := Command_List (C).Unixcmd; ! else ! declare ! Cmd : String (1 .. 5_000); ! Last : Natural := 0; ! Sws : Argument_List_Access := Command_List (C).Unixsws; ! begin ! Cmd (1 .. Command_List (C).Unixcmd'Length) := ! Command_List (C).Unixcmd.all; ! Last := Command_List (C).Unixcmd'Length; ! for J in Sws'Range loop ! Last := Last + 1; ! Cmd (Last) := ' '; ! Cmd (Last + 1 .. Last + Sws (J)'Length) := ! Sws (J).all; ! Last := Last + Sws (J)'Length; ! end loop; ! Command.Unix_String := new String'(Cmd (1 .. Last)); ! end; ! end if; ! Command.Params := Command_List (C).Params; ! Command.Defext := Command_List (C).Defext; ! Validate_Command_Or_Option (Command.Name); ! -- Process the switch list ! for S in Command_List (C).Switches'Range loop ! declare ! SS : constant String_Ptr := Command_List (C).Switches (S); ! P : Natural := SS'First; ! Sw : Item_Ptr := new Switch_Item; ! Last_Opt : Item_Ptr; ! -- Pointer to last option ! begin ! -- Link new switch item into list of switches ! if Last_Switch = null then ! Command.Switches := Sw; ! else Last_Switch.Next := Sw; end if; ! Last_Switch := Sw; ! -- Process switch string, first get name ! while SS (P) /= ' ' and SS (P) /= '=' loop ! P := P + 1; ! end loop; ! Sw.Name := new String'(SS (SS'First .. P - 1)); ! -- Direct translation case ! if SS (P) = ' ' then ! Sw.Translation := T_Direct; ! Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); ! Validate_Unix_Switch (Sw.Unix_String); ! if SS (P - 1) = '>' then ! Sw.Translation := T_Other; ! elsif SS (P + 1) = '`' then ! null; ! -- Create the inverted case (/NO ..) ! elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then ! Sw := new Switch_Item; ! Last_Switch.Next := Sw; ! Last_Switch := Sw; ! Sw.Name := ! new String'("/NO" & SS (SS'First + 1 .. P - 1)); ! Sw.Translation := T_Direct; ! Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); ! Validate_Unix_Switch (Sw.Unix_String); ! end if; ! -- Directories translation case ! elsif SS (P + 1) = '*' then ! pragma Assert (SS (SS'Last) = '*'); ! Sw.Translation := T_Directories; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- Directory translation case ! elsif SS (P + 1) = '%' then ! pragma Assert (SS (SS'Last) = '%'); ! Sw.Translation := T_Directory; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- File translation case ! elsif SS (P + 1) = '@' then ! pragma Assert (SS (SS'Last) = '@'); ! Sw.Translation := T_File; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- No space file translation case ! elsif SS (P + 1) = '<' then ! pragma Assert (SS (SS'Last) = '>'); ! Sw.Translation := T_No_Space_File; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- Numeric translation case ! elsif SS (P + 1) = '#' then ! pragma Assert (SS (SS'Last) = '#'); ! Sw.Translation := T_Numeric; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- Alphanumerplus translation case ! elsif SS (P + 1) = '|' then ! pragma Assert (SS (SS'Last) = '|'); ! Sw.Translation := T_Alphanumplus; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- String translation case ! elsif SS (P + 1) = '"' then ! pragma Assert (SS (SS'Last) = '"'); ! Sw.Translation := T_String; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); ! Validate_Unix_Switch (Sw.Unix_String); ! -- Commands translation case ! elsif SS (P + 1) = '?' then ! Sw.Translation := T_Commands; ! Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); ! -- Options translation case ! else ! Sw.Translation := T_Options; ! Sw.Unix_String := new String'(""); ! P := P + 1; -- bump past = ! while P <= SS'Last loop ! declare ! Opt : Item_Ptr := new Option_Item; ! Q : Natural; ! begin ! -- Link new option item into options list ! if Last_Opt = null then ! Sw.Options := Opt; ! else ! Last_Opt.Next := Opt; ! end if; ! Last_Opt := Opt; ! -- Fill in fields of new option item ! Q := P; ! while SS (Q) /= ' ' loop ! Q := Q + 1; ! end loop; ! Opt.Name := new String'(SS (P .. Q - 1)); ! Validate_Command_Or_Option (Opt.Name); ! P := Q + 1; ! Q := P; ! while Q <= SS'Last and then SS (Q) /= ' ' loop ! Q := Q + 1; ! end loop; ! Opt.Unix_String := new String'(SS (P .. Q - 1)); ! Validate_Unix_Switch (Opt.Unix_String); ! P := Q + 1; ! end; ! end loop; end if; + end; + end loop; + end; + end loop; ! -- If no parameters, give complete list of commands ! if Argument_Count = 0 then ! Output_Version; ! New_Line; ! Put_Line ("List of available commands"); ! New_Line; ! while Commands /= null loop ! Put (Commands.Usage.all); ! Set_Col (53); ! Put_Line (Commands.Unix_String.all); ! Commands := Commands.Next; ! end loop; ! raise Normal_Exit; ! end if; ! Arg_Num := 1; ! -- Loop through arguments ! while Arg_Num <= Argument_Count loop ! Process_Argument : declare ! Argv : String_Access; ! Arg_Idx : Integer; ! function Get_Arg_End ! (Argv : String; ! Arg_Idx : Integer) ! return Integer; ! -- Begins looking at Arg_Idx + 1 and returns the index of the ! -- last character before a slash or else the index of the last ! -- character in the string Argv. ! ----------------- ! -- Get_Arg_End -- ! ----------------- ! function Get_Arg_End ! (Argv : String; ! Arg_Idx : Integer) ! return Integer ! is ! begin ! for J in Arg_Idx + 1 .. Argv'Last loop ! if Argv (J) = '/' then ! return J - 1; ! end if; ! end loop; ! return Argv'Last; ! end Get_Arg_End; ! -- Start of processing for Process_Argument ! begin ! Argv := new String'(Argument (Arg_Num)); ! Arg_Idx := Argv'First; ! <> ! loop ! declare ! Next_Arg_Idx : Integer; ! Arg : String_Access; ! begin ! Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); ! Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); ! -- The first one must be a command name ! if Arg_Num = 1 and then Arg_Idx = Argv'First then ! Command := Matching_Name (Arg.all, Commands); ! if Command = null then ! raise Error_Exit; ! end if; ! The_Command := Command.Command; ! -- Give usage information if only command given ! if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last ! and then Command.Command /= Standard ! then ! Output_Version; ! New_Line; ! Put_Line ! ("List of available qualifiers and options"); ! New_Line; ! Put (Command.Usage.all); ! Set_Col (53); ! Put_Line (Command.Unix_String.all); ! declare ! Sw : Item_Ptr := Command.Switches; ! begin ! while Sw /= null loop ! Put (" "); ! Put (Sw.Name.all); ! case Sw.Translation is ! when T_Other => ! Set_Col (53); ! Put_Line (Sw.Unix_String.all & ! "/"); ! when T_Direct => ! Set_Col (53); ! Put_Line (Sw.Unix_String.all); ! when T_Directories => ! Put ("=(direc,direc,..direc)"); ! Set_Col (53); ! Put (Sw.Unix_String.all); ! Put (" direc "); ! Put (Sw.Unix_String.all); ! Put_Line (" direc ..."); + when T_Directory => + Put ("=directory"); Set_Col (53); ! Put (Sw.Unix_String.all); ! if Sw.Unix_String (Sw.Unix_String'Last) ! /= '=' ! then ! Put (' '); ! end if; ! Put_Line ("directory "); ! when T_File | T_No_Space_File => ! Put ("=file"); ! Set_Col (53); ! Put (Sw.Unix_String.all); ! if Sw.Translation = T_File ! and then Sw.Unix_String ! (Sw.Unix_String'Last) ! /= '=' ! then ! Put (' '); ! end if; ! Put_Line ("file "); ! when T_Numeric => ! Put ("=nnn"); ! Set_Col (53); ! if Sw.Unix_String (Sw.Unix_String'First) ! = '`' ! then ! Put (Sw.Unix_String ! (Sw.Unix_String'First + 1 ! .. Sw.Unix_String'Last)); ! else ! Put (Sw.Unix_String.all); ! end if; ! Put_Line ("nnn"); ! when T_Alphanumplus => ! Put ("=xyz"); ! Set_Col (53); ! if Sw.Unix_String (Sw.Unix_String'First) ! = '`' ! then ! Put (Sw.Unix_String ! (Sw.Unix_String'First + 1 ! .. Sw.Unix_String'Last)); ! else ! Put (Sw.Unix_String.all); ! end if; ! Put_Line ("xyz"); ! when T_String => ! Put ("="); ! Put ('"'); ! Put (""); ! Put ('"'); ! Set_Col (53); ! Put (Sw.Unix_String.all); ! if Sw.Unix_String (Sw.Unix_String'Last) ! /= '=' ! then ! Put (' '); ! end if; ! Put (""); ! New_Line; ! when T_Commands => ! Put (" (switches for "); ! Put (Sw.Unix_String ! (Sw.Unix_String'First + 7 ! .. Sw.Unix_String'Last)); ! Put (')'); ! Set_Col (53); ! Put (Sw.Unix_String ! (Sw.Unix_String'First ! .. Sw.Unix_String'First + 5)); ! Put_Line (" switches"); ! when T_Options => ! declare ! Opt : Item_Ptr := Sw.Options; ! begin ! Put_Line ("=(option,option..)"); ! while Opt /= null loop ! Put (" "); ! Put (Opt.Name.all); ! if Opt = Sw.Options then ! Put (" (D)"); ! end if; ! Set_Col (53); ! Put_Line (Opt.Unix_String.all); ! Opt := Opt.Next; ! end loop; ! end; ! end case; ! Sw := Sw.Next; ! end loop; end; ! raise Normal_Exit; ! end if; ! -- Place (Command.Unix_String.all); ! -- Special handling for internal debugging switch /? ! elsif Arg.all = "/?" then ! Display_Command := True; ! -- Copy -switch unchanged ! elsif Arg (Arg'First) = '-' then ! Place (' '); ! Place (Arg.all); ! -- Copy quoted switch with quotes stripped ! elsif Arg (Arg'First) = '"' then ! if Arg (Arg'Last) /= '"' then ! Put (Standard_Error, "misquoted argument: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! else ! Place (' '); ! Place (Arg (Arg'First + 1 .. Arg'Last - 1)); ! end if; ! -- Parameter Argument ! elsif Arg (Arg'First) /= '/' ! and then Make_Commands_Active = null ! then ! Param_Count := Param_Count + 1; ! if Param_Count <= Command.Params'Length then ! ! case Command.Params (Param_Count) is + when File | Optional_File => + declare + Normal_File : String_Access + := To_Canonical_File_Spec (Arg.all); begin Place (' '); Place_Lower (Normal_File.all); *************** begin *** 2797,3313 **** Place ('.'); Place (Command.Defext); end if; - - Arg1_Idx := Next_Arg1_Idx + 1; end; ! exit when Arg1_Idx > Arg'Last; ! -- Don't allow two or more commas in a row ! if Arg (Arg1_Idx) = ',' then ! Arg1_Idx := Arg1_Idx + 1; ! if Arg1_Idx > Arg'Last or else ! Arg (Arg1_Idx) = ',' ! then ! Put_Line (Standard_Error, ! "Malformed Parameter: " & Arg.all); ! Put (Standard_Error, "usage: "); ! Put_Line (Standard_Error, ! Command.Usage.all); ! raise Error_Exit; end if; - end if; ! end loop; ! end; ! end case; ! end if; ! -- Qualifier argument ! else ! declare ! Sw : Item_Ptr; ! SwP : Natural; ! P2 : Natural; ! Endp : Natural := 0; -- avoid warning! ! Opt : Item_Ptr; ! begin ! SwP := Arg'First; ! while SwP < Arg'Last and then Arg (SwP + 1) /= '=' loop ! SwP := SwP + 1; ! end loop; ! -- At this point, the switch name is in ! -- Arg (Arg'First..SwP) and if that is not the whole ! -- switch, then there is an equal sign at ! -- Arg (SwP + 1) and the rest of Arg is what comes ! -- after the equal sign. ! -- If make commands are active, see if we have another ! -- COMMANDS_TRANSLATION switch belonging to gnatmake. ! if Make_Commands_Active /= null then ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Command.Switches, ! Quiet => True); ! if Sw /= null and then Sw.Translation = T_Commands then ! null; ! else ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Make_Commands_Active.Switches, ! Quiet => False); ! end if; ! -- For case of GNAT MAKE or CHOP, if we cannot find the ! -- switch, then see if it is a recognized compiler switch ! -- instead, and if so process the compiler switch. ! elsif Command.Name.all = "MAKE" ! or else Command.Name.all = "CHOP" then ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Command.Switches, ! Quiet => True); ! if Sw = null then ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Matching_Name ("COMPILE", Commands).Switches, ! Quiet => False); end if; ! -- For all other cases, just search the relevant command else ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Command.Switches, ! Quiet => False); ! end if; ! if Sw /= null then ! case Sw.Translation is ! when T_Direct => ! Place_Unix_Switches (Sw.Unix_String); ! if Arg (SwP + 1) = '=' then ! Put (Standard_Error, ! "qualifier options ignored: "); ! Put_Line (Standard_Error, Arg.all); ! end if; ! when T_Directories => ! if SwP + 1 > Arg'Last then ! Put (Standard_Error, ! "missing directories for: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! elsif Arg (SwP + 2) /= '(' then ! SwP := SwP + 2; ! Endp := Arg'Last; ! elsif Arg (Arg'Last) /= ')' then ! -- Remove spaces from a comma separated list ! -- of file names and adjust control ! -- variables accordingly. ! if Arg_Num < Argument_Count and then ! (Argv (Argv'Last) = ',' xor ! Argument (Arg_Num + 1) ! (Argument (Arg_Num + 1)'First) = ',') ! then ! Argv := new String'(Argv.all ! & Argument (Arg_Num + 1)); ! Arg_Num := Arg_Num + 1; ! Arg_Idx := Argv'First; ! Next_Arg_Idx ! := Get_Arg_End (Argv.all, Arg_Idx); ! Arg := new String' ! (Argv (Arg_Idx .. Next_Arg_Idx)); ! goto Tryagain_After_Coalesce; ! end if; ! Put (Standard_Error, ! "incorrectly parenthesized " & ! "or malformed argument: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! else ! SwP := SwP + 3; ! Endp := Arg'Last - 1; end if; ! while SwP <= Endp loop ! declare ! Dir_Is_Wild : Boolean := False; ! Dir_Maybe_Is_Wild : Boolean := False; ! Dir_List : String_Access_List_Access; ! begin ! P2 := SwP; ! while P2 < Endp ! and then Arg (P2 + 1) /= ',' ! loop ! -- A wildcard directory spec on VMS ! -- will contain either * or % or ... ! if Arg (P2) = '*' then ! Dir_Is_Wild := True; ! elsif Arg (P2) = '%' then ! Dir_Is_Wild := True; ! elsif Dir_Maybe_Is_Wild ! and then Arg (P2) = '.' ! and then Arg (P2 + 1) = '.' then ! Dir_Is_Wild := True; ! Dir_Maybe_Is_Wild := False; ! elsif Dir_Maybe_Is_Wild then ! Dir_Maybe_Is_Wild := False; ! elsif Arg (P2) = '.' ! and then Arg (P2 + 1) = '.' then ! Dir_Maybe_Is_Wild := True; end if; ! P2 := P2 + 1; ! end loop; ! if (Dir_Is_Wild) then ! Dir_List := To_Canonical_File_List ! (Arg (SwP .. P2), True); - for I in Dir_List.all'Range loop - Place_Unix_Switches (Sw.Unix_String); - Place_Lower (Dir_List.all (I).all); - end loop; else Place_Unix_Switches (Sw.Unix_String); ! Place_Lower (To_Canonical_Dir_Spec ! (Arg (SwP .. P2), False).all); end if; ! SwP := P2 + 2; ! end; ! end loop; ! when T_Directory => ! if SwP + 1 > Arg'Last then ! Put (Standard_Error, ! "missing directory for: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! else ! Place_Unix_Switches (Sw.Unix_String); ! -- Some switches end in "=". No space here - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then Place (' '); ! end if; ! Place_Lower (To_Canonical_Dir_Spec ! (Arg (SwP + 2 .. Arg'Last), False).all); ! end if; ! when T_File => ! if SwP + 1 > Arg'Last then ! Put (Standard_Error, "missing file for: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! else ! Place_Unix_Switches (Sw.Unix_String); ! -- Some switches end in "=". No space here ! if Sw.Unix_String ! (Sw.Unix_String'Last) /= '=' ! then ! Place (' '); ! end if; ! Place_Lower (To_Canonical_File_Spec ! (Arg (SwP + 2 .. Arg'Last)).all); ! end if; ! when T_Numeric => ! if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then ! Place_Unix_Switches (Sw.Unix_String); ! Place (Arg (SwP + 2 .. Arg'Last)); ! else ! Put (Standard_Error, "argument for "); ! Put (Standard_Error, Sw.Name.all); ! Put_Line (Standard_Error, " must be numeric"); ! Errors := Errors + 1; ! end if; ! when T_Alphanumplus => ! if ! OK_Alphanumerplus (Arg (SwP + 2 .. Arg'Last)) ! then ! Place_Unix_Switches (Sw.Unix_String); ! Place (Arg (SwP + 2 .. Arg'Last)); ! else ! Put (Standard_Error, "argument for "); ! Put (Standard_Error, Sw.Name.all); ! Put_Line (Standard_Error, ! " must be alphanumeric"); ! Errors := Errors + 1; ! end if; ! when T_String => ! -- A String value must be extended to the ! -- end of the Argv, otherwise strings like ! -- "foo/bar" get split at the slash. ! -- ! -- The begining and ending of the string ! -- are flagged with embedded nulls which ! -- are removed when building the Spawn ! -- call. Nulls are use because they won't ! -- show up in a /? output. Quotes aren't ! -- used because that would make it difficult ! -- to embed them. ! Place_Unix_Switches (Sw.Unix_String); ! if Next_Arg_Idx /= Argv'Last then ! Next_Arg_Idx := Argv'Last; ! Arg := new String' ! (Argv (Arg_Idx .. Next_Arg_Idx)); ! SwP := Arg'First; ! while SwP < Arg'Last and then ! Arg (SwP + 1) /= '=' loop ! SwP := SwP + 1; ! end loop; ! end if; ! Place (ASCII.NUL); ! Place (Arg (SwP + 2 .. Arg'Last)); ! Place (ASCII.NUL); ! when T_Commands => ! -- Output -largs/-bargs/-cargs ! Place (' '); ! Place (Sw.Unix_String ! (Sw.Unix_String'First .. ! Sw.Unix_String'First + 5)); ! -- Set source of new commands, also setting this ! -- non-null indicates that we are in the special ! -- commands mode for processing the -xargs case. ! Make_Commands_Active := ! Matching_Name ! (Sw.Unix_String ! (Sw.Unix_String'First + 7 .. ! Sw.Unix_String'Last), ! Commands); ! when T_Options => ! if SwP + 1 > Arg'Last then ! Place_Unix_Switches (Sw.Options.Unix_String); ! SwP := Endp + 1; ! elsif Arg (SwP + 2) /= '(' then ! SwP := SwP + 2; ! Endp := Arg'Last; ! elsif Arg (Arg'Last) /= ')' then ! Put (Standard_Error, ! "incorrectly parenthesized argument: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! SwP := Endp + 1; ! else ! SwP := SwP + 3; ! Endp := Arg'Last - 1; ! end if; ! while SwP <= Endp loop ! P2 := SwP; ! while P2 < Endp ! and then Arg (P2 + 1) /= ',' ! loop ! P2 := P2 + 1; ! end loop; ! -- Option name is in Arg (SwP .. P2) ! Opt := Matching_Name (Arg (SwP .. P2), ! Sw.Options); ! if Opt /= null then ! Place_Unix_Switches (Opt.Unix_String); ! end if; ! SwP := P2 + 2; ! end loop; ! when T_Other => ! Place_Unix_Switches ! (new String'(Sw.Unix_String.all & Arg.all)); ! end case; end if; ! end; end if; ! Arg_Idx := Next_Arg_Idx + 1; ! end; ! exit when Arg_Idx > Argv'Last; ! end loop; ! end; ! Arg_Num := Arg_Num + 1; ! end loop; ! if Display_Command then ! Put (Standard_Error, "generated command -->"); ! Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last))); ! Put (Standard_Error, "<--"); ! New_Line (Standard_Error); ! raise Normal_Exit; ! end if; ! -- Gross error checking that the number of parameters is correct. ! -- Not applicable to Unlimited_Files parameters. ! if not ((Param_Count = Command.Params'Length - 1 and then ! Command.Params (Param_Count + 1) = Unlimited_Files) ! or else (Param_Count <= Command.Params'Length)) then ! Put_Line (Standard_Error, ! "Parameter count of " ! & Integer'Image (Param_Count) ! & " not equal to expected " ! & Integer'Image (Command.Params'Length)); ! Put (Standard_Error, "usage: "); ! Put_Line (Standard_Error, Command.Usage.all); ! Errors := Errors + 1; ! end if; - if Errors > 0 then - raise Error_Exit; else ! -- Prepare arguments for a call to spawn, filtering out ! -- embedded nulls place there to delineate strings. ! declare ! Pname_Ptr : Natural; ! Args : Argument_List (1 .. 500); ! Nargs : Natural; ! P1, P2 : Natural; ! Exec_Path : String_Access; ! Inside_Nul : Boolean := False; ! Arg : String (1 .. 1024); ! Arg_Ctr : Natural; ! begin ! Pname_Ptr := 1; ! while Pname_Ptr < Buffer.Last ! and then Buffer.Table (Pname_Ptr + 1) /= ' ' ! loop ! Pname_Ptr := Pname_Ptr + 1; end loop; ! P1 := Pname_Ptr + 2; ! Arg_Ctr := 1; ! Arg (Arg_Ctr) := Buffer.Table (P1); ! Nargs := 0; ! while P1 <= Buffer.Last loop ! if Buffer.Table (P1) = ASCII.NUL then ! if Inside_Nul then ! Inside_Nul := False; ! else ! Inside_Nul := True; ! end if; ! end if; ! if Buffer.Table (P1) = ' ' and then not Inside_Nul then ! P1 := P1 + 1; ! Arg_Ctr := Arg_Ctr + 1; ! Arg (Arg_Ctr) := Buffer.Table (P1); ! else ! Nargs := Nargs + 1; ! P2 := P1; - while P2 < Buffer.Last - and then (Buffer.Table (P2 + 1) /= ' ' or else - Inside_Nul) - loop - P2 := P2 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := Buffer.Table (P2); - if Buffer.Table (P2) = ASCII.NUL then - Arg_Ctr := Arg_Ctr - 1; - if Inside_Nul then - Inside_Nul := False; else ! Inside_Nul := True; end if; end if; - end loop; ! Args (Nargs) := new String'(String (Arg (1 .. Arg_Ctr))); ! P1 := P2 + 2; ! Arg_Ctr := 1; ! Arg (Arg_Ctr) := Buffer.Table (P1); end if; end loop; ! Exec_Path := Locate_Exec_On_Path ! (String (Buffer.Table (1 .. Pname_Ptr))); ! if Exec_Path = null then ! Put_Line (Standard_Error, ! "Couldn't locate " ! & String (Buffer.Table (1 .. Pname_Ptr))); ! raise Error_Exit; end if; My_Exit_Status ! := Exit_Status (Spawn (Exec_Path.all, Args (1 .. Nargs))); ! end; ! ! raise Normal_Exit; ! end if; exception when Error_Exit => --- 3150,4258 ---- Place ('.'); Place (Command.Defext); end if; end; ! when Unlimited_Files => ! declare ! Normal_File : String_Access ! := To_Canonical_File_Spec (Arg.all); ! File_Is_Wild : Boolean := False; ! File_List : String_Access_List_Access; ! begin ! for I in Arg'Range loop ! if Arg (I) = '*' ! or else Arg (I) = '%' ! then ! File_Is_Wild := True; ! end if; ! end loop; ! if File_Is_Wild then ! File_List := To_Canonical_File_List ! (Arg.all, False); ! ! for I in File_List.all'Range loop ! Place (' '); ! Place_Lower (File_List.all (I).all); ! end loop; ! else ! Place (' '); ! Place_Lower (Normal_File.all); ! ! if Is_Extensionless (Normal_File.all) ! and then Command.Defext /= " " ! then ! Place ('.'); ! Place (Command.Defext); ! end if; end if; ! Param_Count := Param_Count - 1; ! end; ! when Other_As_Is => ! Place (' '); ! Place (Arg.all); ! when Unlimited_As_Is => ! Place (' '); ! Place (Arg.all); ! Param_Count := Param_Count - 1; ! when Files_Or_Wildcard => ! -- Remove spaces from a comma separated list ! -- of file names and adjust control variables ! -- accordingly. ! while Arg_Num < Argument_Count and then ! (Argv (Argv'Last) = ',' xor ! Argument (Arg_Num + 1) ! (Argument (Arg_Num + 1)'First) = ',') ! loop ! Argv := new String' ! (Argv.all & Argument (Arg_Num + 1)); ! Arg_Num := Arg_Num + 1; ! Arg_Idx := Argv'First; ! Next_Arg_Idx := ! Get_Arg_End (Argv.all, Arg_Idx); ! Arg := new String' ! (Argv (Arg_Idx .. Next_Arg_Idx)); ! end loop; ! -- Parse the comma separated list of VMS ! -- filenames and place them on the command ! -- line as space separated Unix style ! -- filenames. Lower case and add default ! -- extension as appropriate. ! declare ! Arg1_Idx : Integer := Arg'First; ! function Get_Arg1_End ! (Arg : String; Arg_Idx : Integer) ! return Integer; ! -- Begins looking at Arg_Idx + 1 and ! -- returns the index of the last character ! -- before a comma or else the index of the ! -- last character in the string Arg. ! function Get_Arg1_End ! (Arg : String; Arg_Idx : Integer) ! return Integer ! is ! begin ! for I in Arg_Idx + 1 .. Arg'Last loop ! if Arg (I) = ',' then ! return I - 1; ! end if; ! end loop; ! return Arg'Last; ! end Get_Arg1_End; ! begin ! loop ! declare ! Next_Arg1_Idx : Integer := ! Get_Arg1_End (Arg.all, Arg1_Idx); ! ! Arg1 : String := ! Arg (Arg1_Idx .. Next_Arg1_Idx); ! ! Normal_File : String_Access := ! To_Canonical_File_Spec (Arg1); ! ! begin ! Place (' '); ! Place_Lower (Normal_File.all); ! ! if Is_Extensionless (Normal_File.all) ! and then Command.Defext /= " " ! then ! Place ('.'); ! Place (Command.Defext); ! end if; ! ! Arg1_Idx := Next_Arg1_Idx + 1; ! end; ! ! exit when Arg1_Idx > Arg'Last; ! ! -- Don't allow two or more commas in ! -- a row ! ! if Arg (Arg1_Idx) = ',' then ! Arg1_Idx := Arg1_Idx + 1; ! if Arg1_Idx > Arg'Last or else ! Arg (Arg1_Idx) = ',' ! then ! Put_Line ! (Standard_Error, ! "Malformed Parameter: " & ! Arg.all); ! Put (Standard_Error, "usage: "); ! Put_Line (Standard_Error, ! Command.Usage.all); ! raise Error_Exit; ! end if; ! end if; ! ! end loop; ! end; ! end case; end if; ! -- Qualifier argument else ! declare ! Sw : Item_Ptr; ! SwP : Natural; ! P2 : Natural; ! Endp : Natural := 0; -- avoid warning! ! Opt : Item_Ptr; ! begin ! SwP := Arg'First; ! while SwP < Arg'Last ! and then Arg (SwP + 1) /= '=' ! loop ! SwP := SwP + 1; ! end loop; ! -- At this point, the switch name is in ! -- Arg (Arg'First..SwP) and if that is not the ! -- whole switch, then there is an equal sign at ! -- Arg (SwP + 1) and the rest of Arg is what comes ! -- after the equal sign. ! -- If make commands are active, see if we have ! -- another COMMANDS_TRANSLATION switch belonging ! -- to gnatmake. ! if Make_Commands_Active /= null then ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Command.Switches, ! Quiet => True); ! if Sw /= null ! and then Sw.Translation = T_Commands ! then ! null; ! else ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Make_Commands_Active.Switches, ! Quiet => False); ! end if; ! -- For case of GNAT MAKE or CHOP, if we cannot ! -- find the switch, then see if it is a ! -- recognized compiler switch instead, and if ! -- so process the compiler switch. ! elsif Command.Name.all = "MAKE" ! or else Command.Name.all = "CHOP" then ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Command.Switches, ! Quiet => True); ! if Sw = null then ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Matching_Name ! ("COMPILE", Commands).Switches, ! Quiet => False); end if; ! -- For all other cases, just search the relevant ! -- command. ! else ! Sw := ! Matching_Name ! (Arg (Arg'First .. SwP), ! Command.Switches, ! Quiet => False); ! end if; ! if Sw /= null then ! case Sw.Translation is ! when T_Direct => ! Place_Unix_Switches (Sw.Unix_String); ! if SwP < Arg'Last ! and then Arg (SwP + 1) = '=' ! then ! Put (Standard_Error, ! "qualifier options ignored: "); ! Put_Line (Standard_Error, Arg.all); ! end if; ! when T_Directories => ! if SwP + 1 > Arg'Last then ! Put (Standard_Error, ! "missing directories for: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! elsif Arg (SwP + 2) /= '(' then ! SwP := SwP + 2; ! Endp := Arg'Last; ! ! elsif Arg (Arg'Last) /= ')' then ! ! -- Remove spaces from a comma separated ! -- list of file names and adjust ! -- control variables accordingly. ! ! if Arg_Num < Argument_Count and then ! (Argv (Argv'Last) = ',' xor ! Argument (Arg_Num + 1) ! (Argument (Arg_Num + 1)'First) = ',') then ! Argv := ! new String'(Argv.all ! & Argument ! (Arg_Num + 1)); ! Arg_Num := Arg_Num + 1; ! Arg_Idx := Argv'First; ! Next_Arg_Idx ! := Get_Arg_End (Argv.all, Arg_Idx); ! Arg := new String' ! (Argv (Arg_Idx .. Next_Arg_Idx)); ! goto Tryagain_After_Coalesce; ! end if; ! Put (Standard_Error, ! "incorrectly parenthesized " & ! "or malformed argument: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! else ! SwP := SwP + 3; ! Endp := Arg'Last - 1; ! end if; ! ! while SwP <= Endp loop ! declare ! Dir_Is_Wild : Boolean := False; ! Dir_Maybe_Is_Wild : Boolean := False; ! Dir_List : String_Access_List_Access; ! begin ! P2 := SwP; ! ! while P2 < Endp ! and then Arg (P2 + 1) /= ',' ! loop ! ! -- A wildcard directory spec on ! -- VMS will contain either * or ! -- % or ... ! ! if Arg (P2) = '*' then ! Dir_Is_Wild := True; ! ! elsif Arg (P2) = '%' then ! Dir_Is_Wild := True; ! ! elsif Dir_Maybe_Is_Wild ! and then Arg (P2) = '.' ! and then Arg (P2 + 1) = '.' ! then ! Dir_Is_Wild := True; ! Dir_Maybe_Is_Wild := False; ! ! elsif Dir_Maybe_Is_Wild then ! Dir_Maybe_Is_Wild := False; ! ! elsif Arg (P2) = '.' ! and then Arg (P2 + 1) = '.' ! then ! Dir_Maybe_Is_Wild := True; ! ! end if; ! ! P2 := P2 + 1; ! end loop; ! ! if (Dir_Is_Wild) then ! Dir_List := To_Canonical_File_List ! (Arg (SwP .. P2), True); ! ! for I in Dir_List.all'Range loop ! Place_Unix_Switches ! (Sw.Unix_String); ! Place_Lower ! (Dir_List.all (I).all); ! end loop; ! else ! Place_Unix_Switches ! (Sw.Unix_String); ! Place_Lower ! (To_Canonical_Dir_Spec ! (Arg (SwP .. P2), False).all); ! end if; ! ! SwP := P2 + 2; ! end; ! end loop; ! ! when T_Directory => ! if SwP + 1 > Arg'Last then ! Put (Standard_Error, ! "missing directory for: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! ! else ! Place_Unix_Switches (Sw.Unix_String); ! ! -- Some switches end in "=". No space ! -- here ! ! if Sw.Unix_String ! (Sw.Unix_String'Last) /= '=' then ! Place (' '); ! end if; + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP + 2 .. Arg'Last), + False).all); + end if; + + when T_File | T_No_Space_File => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing file for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); + + -- Some switches end in "=". No space + -- here. + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); end if; ! Place_Lower ! (To_Canonical_File_Spec ! (Arg (SwP + 2 .. Arg'Last)).all); ! end if; ! when T_Numeric => ! if ! OK_Integer (Arg (SwP + 2 .. Arg'Last)) ! then ! Place_Unix_Switches (Sw.Unix_String); ! Place (Arg (SwP + 2 .. Arg'Last)); else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line + (Standard_Error, " must be numeric"); + Errors := Errors + 1; + end if; + + when T_Alphanumplus => + if + OK_Alphanumerplus + (Arg (SwP + 2 .. Arg'Last)) + then Place_Unix_Switches (Sw.Unix_String); ! Place (Arg (SwP + 2 .. Arg'Last)); ! ! else ! Put (Standard_Error, "argument for "); ! Put (Standard_Error, Sw.Name.all); ! Put_Line (Standard_Error, ! " must be alphanumeric"); ! Errors := Errors + 1; end if; ! when T_String => ! -- A String value must be extended to the ! -- end of the Argv, otherwise strings like ! -- "foo/bar" get split at the slash. ! -- ! -- The begining and ending of the string ! -- are flagged with embedded nulls which ! -- are removed when building the Spawn ! -- call. Nulls are use because they won't ! -- show up in a /? output. Quotes aren't ! -- used because that would make it ! -- difficult to embed them. ! Place_Unix_Switches (Sw.Unix_String); ! if Next_Arg_Idx /= Argv'Last then ! Next_Arg_Idx := Argv'Last; ! Arg := new String' ! (Argv (Arg_Idx .. Next_Arg_Idx)); ! SwP := Arg'First; ! while SwP < Arg'Last and then ! Arg (SwP + 1) /= '=' loop ! SwP := SwP + 1; ! end loop; ! end if; ! Place (ASCII.NUL); ! Place (Arg (SwP + 2 .. Arg'Last)); ! Place (ASCII.NUL); ! ! when T_Commands => ! ! -- Output -largs/-bargs/-cargs Place (' '); ! Place (Sw.Unix_String ! (Sw.Unix_String'First .. ! Sw.Unix_String'First + 5)); ! -- Set source of new commands, also ! -- setting this non-null indicates that ! -- we are in the special commands mode ! -- for processing the -xargs case. ! Make_Commands_Active := ! Matching_Name ! (Sw.Unix_String ! (Sw.Unix_String'First + 7 .. ! Sw.Unix_String'Last), ! Commands); ! when T_Options => ! if SwP + 1 > Arg'Last then ! Place_Unix_Switches ! (Sw.Options.Unix_String); ! SwP := Endp + 1; ! elsif Arg (SwP + 2) /= '(' then ! SwP := SwP + 2; ! Endp := Arg'Last; ! elsif Arg (Arg'Last) /= ')' then ! Put ! (Standard_Error, ! "incorrectly parenthesized " & ! "argument: "); ! Put_Line (Standard_Error, Arg.all); ! Errors := Errors + 1; ! SwP := Endp + 1; ! else ! SwP := SwP + 3; ! Endp := Arg'Last - 1; ! end if; ! while SwP <= Endp loop ! P2 := SwP; ! while P2 < Endp ! and then Arg (P2 + 1) /= ',' ! loop ! P2 := P2 + 1; ! end loop; ! -- Option name is in Arg (SwP .. P2) ! Opt := Matching_Name (Arg (SwP .. P2), ! Sw.Options); ! if Opt /= null then ! Place_Unix_Switches ! (Opt.Unix_String); ! end if; ! SwP := P2 + 2; ! end loop; ! when T_Other => ! Place_Unix_Switches ! (new String'(Sw.Unix_String.all & ! Arg.all)); ! end case; ! end if; ! end; ! end if; ! Arg_Idx := Next_Arg_Idx + 1; ! end; ! exit when Arg_Idx > Argv'Last; ! end loop; ! end Process_Argument; ! Arg_Num := Arg_Num + 1; ! end loop; ! if Display_Command then ! Put (Standard_Error, "generated command -->"); ! Put (Standard_Error, Command_List (The_Command).Unixcmd.all); ! if Command_List (The_Command).Unixsws /= null then ! for J in Command_List (The_Command).Unixsws'Range loop ! Put (Standard_Error, " "); ! Put (Standard_Error, ! Command_List (The_Command).Unixsws (J).all); ! end loop; ! end if; ! Put (Standard_Error, " "); ! Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last))); ! Put (Standard_Error, "<--"); ! New_Line (Standard_Error); ! raise Normal_Exit; ! end if; ! -- Gross error checking that the number of parameters is correct. ! -- Not applicable to Unlimited_Files parameters. ! if (Param_Count = Command.Params'Length - 1 ! and then Command.Params (Param_Count + 1) = Unlimited_Files) ! or else Param_Count <= Command.Params'Length ! then ! null; ! else ! Put_Line (Standard_Error, ! "Parameter count of " ! & Integer'Image (Param_Count) ! & " not equal to expected " ! & Integer'Image (Command.Params'Length)); ! Put (Standard_Error, "usage: "); ! Put_Line (Standard_Error, Command.Usage.all); ! Errors := Errors + 1; ! end if; ! if Errors > 0 then ! raise Error_Exit; ! else ! -- Prepare arguments for a call to spawn, filtering out ! -- embedded nulls place there to delineate strings. ! declare ! P1, P2 : Natural; ! Inside_Nul : Boolean := False; ! Arg : String (1 .. 1024); ! Arg_Ctr : Natural; ! begin ! P1 := 1; ! while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop ! P1 := P1 + 1; ! end loop; ! Arg_Ctr := 1; ! Arg (Arg_Ctr) := Buffer.Table (P1); ! while P1 <= Buffer.Last loop ! if Buffer.Table (P1) = ASCII.NUL then ! if Inside_Nul then ! Inside_Nul := False; ! else ! Inside_Nul := True; ! end if; ! end if; ! ! if Buffer.Table (P1) = ' ' and then not Inside_Nul then ! P1 := P1 + 1; ! Arg_Ctr := Arg_Ctr + 1; ! Arg (Arg_Ctr) := Buffer.Table (P1); ! ! else ! Last_Switches.Increment_Last; ! P2 := P1; ! ! while P2 < Buffer.Last ! and then (Buffer.Table (P2 + 1) /= ' ' or else ! Inside_Nul) ! loop ! P2 := P2 + 1; ! Arg_Ctr := Arg_Ctr + 1; ! Arg (Arg_Ctr) := Buffer.Table (P2); ! if Buffer.Table (P2) = ASCII.NUL then ! Arg_Ctr := Arg_Ctr - 1; ! if Inside_Nul then ! Inside_Nul := False; ! else ! Inside_Nul := True; ! end if; end if; ! end loop; ! ! Last_Switches.Table (Last_Switches.Last) := ! new String'(String (Arg (1 .. Arg_Ctr))); ! P1 := P2 + 2; ! Arg_Ctr := 1; ! Arg (Arg_Ctr) := Buffer.Table (P1); end if; + end loop; + end; + end if; + end VMS_Conversion; ! ------------------------------------- ! -- Start of processing for GNATCmd -- ! ------------------------------------- ! begin ! -- Initializations ! Namet.Initialize; ! Csets.Initialize; ! Snames.Initialize; ! Prj.Initialize; ! Last_Switches.Init; ! Last_Switches.Set_Last (0); ! First_Switches.Init; ! First_Switches.Set_Last (0); ! ! -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, ! -- filenames and pathnames to Unix style. ! ! if Hostparm.OpenVMS ! or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" then ! VMS_Conversion (The_Command); ! ! -- If not on VMS, scan the command line directly else ! if Argument_Count = 0 then ! Non_VMS_Usage; ! return; ! else ! begin ! if Argument_Count > 1 and then Argument (1) = "-v" then ! Opt.Verbose_Mode := True; ! Command_Arg := 2; ! end if; ! The_Command := Real_Command_Type'Value (Argument (Command_Arg)); ! if Command_List (The_Command).VMS_Only then ! Non_VMS_Usage; ! Fail ("Command """ & Command_List (The_Command).Cname.all & ! """ can only be used on VMS"); ! end if; ! exception ! when Constraint_Error => ! -- Check if it is an alternate command ! declare ! Alternate : Alternate_Command; ! ! begin ! Alternate := Alternate_Command'Value ! (Argument (Command_Arg)); ! The_Command := Corresponding_To (Alternate); ! ! exception ! when Constraint_Error => ! Non_VMS_Usage; ! Fail ("Unknown command: " & Argument (Command_Arg)); ! end; ! end; ! ! for Arg in Command_Arg + 1 .. Argument_Count loop ! Last_Switches.Increment_Last; ! Last_Switches.Table (Last_Switches.Last) := ! new String'(Argument (Arg)); end loop; + end if; + end if; ! declare ! Program : constant String := ! Program_Name (Command_List (The_Command).Unixcmd.all).all; ! Exec_Path : String_Access; ! begin ! -- Locate the executable for the command ! Exec_Path := Locate_Exec_On_Path (Program); ! if Exec_Path = null then ! Put_Line (Standard_Error, "Couldn't locate " & Program); ! raise Error_Exit; ! end if; ! ! -- If there are switches for the executable, put them as first switches ! ! if Command_List (The_Command).Unixsws /= null then ! for J in Command_List (The_Command).Unixsws'Range loop ! First_Switches.Increment_Last; ! First_Switches.Table (First_Switches.Last) := ! Command_List (The_Command).Unixsws (J); ! end loop; ! end if; ! ! -- For BIND, FIND, LINK, LIST and XREF, look for project file related ! -- switches. ! ! if The_Command = Bind ! or else The_Command = Find ! or else The_Command = Link ! or else The_Command = List ! or else The_Command = Xref ! then ! case The_Command is ! when Bind => ! Tool_Package_Name := Name_Binder; ! when Find => ! Tool_Package_Name := Name_Finder; ! when Link => ! Tool_Package_Name := Name_Linker; ! when List => ! Tool_Package_Name := Name_Gnatls; ! when Xref => ! Tool_Package_Name := Name_Cross_Reference; ! when others => ! null; ! end case; ! ! declare ! Arg_Num : Positive := 1; ! Argv : String_Access; ! ! procedure Remove_Switch (Num : Positive); ! -- Remove a project related switch from table Last_Switches ! ! ------------------- ! -- Remove_Switch -- ! ------------------- ! ! procedure Remove_Switch (Num : Positive) is ! begin ! Last_Switches.Table (Num .. Last_Switches.Last - 1) := ! Last_Switches.Table (Num + 1 .. Last_Switches.Last); ! Last_Switches.Decrement_Last; ! end Remove_Switch; ! ! -- Start of processing for ??? (need block name here) ! ! begin ! while Arg_Num <= Last_Switches.Last loop ! Argv := Last_Switches.Table (Arg_Num); ! ! if Argv (Argv'First) = '-' then ! if Argv'Length = 1 then ! Fail ("switch character cannot be followed by a blank"); ! end if; ! ! -- The two style project files (-p and -P) cannot be used ! -- together ! ! if (The_Command = Find or else The_Command = Xref) ! and then Argv (2) = 'p' ! then ! Old_Project_File_Used := True; ! if Project_File /= null then ! Fail ("-P and -p cannot be used together"); ! end if; ! end if; ! ! -- -vPx Specify verbosity while parsing project files ! ! if Argv'Length = 4 ! and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" ! then ! case Argv (Argv'Last) is ! when '0' => ! Current_Verbosity := Prj.Default; ! when '1' => ! Current_Verbosity := Prj.Medium; ! when '2' => ! Current_Verbosity := Prj.High; ! when others => ! Fail ("Invalid switch: " & Argv.all); ! end case; ! ! Remove_Switch (Arg_Num); ! ! -- -Pproject_file Specify project file to be used ! ! elsif Argv'Length >= 3 ! and then Argv (Argv'First + 1) = 'P' ! then ! ! -- Only one -P switch can be used ! ! if Project_File /= null then ! Fail (Argv.all & ! ": second project file forbidden (first is """ & ! Project_File.all & """)"); ! ! -- The two style project files (-p and -P) cannot be ! -- used together. ! ! elsif Old_Project_File_Used then ! Fail ("-p and -P cannot be used together"); else ! Project_File := ! new String'(Argv (Argv'First + 2 .. Argv'Last)); end if; + + Remove_Switch (Arg_Num); + + -- -Xexternal=value Specify an external reference to be + -- used in project files + + elsif Argv'Length >= 5 + and then Argv (Argv'First + 1) = 'X' + then + declare + Equal_Pos : constant Natural := + Index ('=', Argv (Argv'First + 2 .. Argv'Last)); + begin + if Equal_Pos >= Argv'First + 3 and then + Equal_Pos /= Argv'Last then + Add (External_Name => + Argv (Argv'First + 2 .. Equal_Pos - 1), + Value => Argv (Equal_Pos + 1 .. Argv'Last)); + else + Fail (Argv.all & + " is not a valid external assignment."); + end if; + end; + + Remove_Switch (Arg_Num); + + else + Arg_Num := Arg_Num + 1; end if; ! else ! Arg_Num := Arg_Num + 1; ! end if; ! end loop; ! end; ! end if; ! ! -- If there is a project file specified, parse it, get the switches ! -- for the tool and setup PATH environment variables. ! ! if Project_File /= null then ! Prj.Pars.Set_Verbosity (To => Current_Verbosity); ! ! Prj.Pars.Parse ! (Project => Project, ! Project_File_Name => Project_File.all); ! ! if Project = Prj.No_Project then ! Fail ("""" & Project_File.all & """ processing failed"); ! end if; ! ! -- Check if a package with the name of the tool is in the project ! -- file and if there is one, get the switches, if any, and scan them. ! ! declare ! Data : Prj.Project_Data := Prj.Projects.Table (Project); ! Pkg : Prj.Package_Id := ! Prj.Util.Value_Of ! (Name => Tool_Package_Name, ! In_Packages => Data.Decl.Packages); ! ! Element : Package_Element; ! ! Default_Switches_Array : Array_Element_Id; ! ! The_Switches : Prj.Variable_Value; ! Current : Prj.String_List_Id; ! The_String : String_Element; ! ! begin ! if Pkg /= No_Package then ! Element := Packages.Table (Pkg); ! ! -- Packages Gnatls has a single attribute Switches, that is ! -- not an associative array. ! ! if The_Command = List then ! The_Switches := ! Prj.Util.Value_Of ! (Variable_Name => Snames.Name_Switches, ! In_Variables => Element.Decl.Attributes); ! ! -- Packages Binder (for gnatbind), Cross_Reference (for ! -- gnatxref), Linker (for gnatlink) and Finder ! -- (for gnatfind) have an attributed Default_Switches, ! -- an associative array, indexed by the name of the ! -- programming language. ! else ! Default_Switches_Array := ! Prj.Util.Value_Of ! (Name => Name_Default_Switches, ! In_Arrays => Packages.Table (Pkg).Decl.Arrays); ! The_Switches := Prj.Util.Value_Of ! (Index => Name_Ada, ! In_Array => Default_Switches_Array); ! ! end if; ! ! -- If there are switches specified in the package of the ! -- project file corresponding to the tool, scan them. ! ! case The_Switches.Kind is ! when Prj.Undefined => ! null; ! ! when Prj.Single => ! if String_Length (The_Switches.Value) > 0 then ! String_To_Name_Buffer (The_Switches.Value); ! First_Switches.Increment_Last; ! First_Switches.Table (First_Switches.Last) := ! new String'(Name_Buffer (1 .. Name_Len)); ! end if; ! ! when Prj.List => ! Current := The_Switches.Values; ! while Current /= Prj.Nil_String loop ! The_String := String_Elements.Table (Current); ! ! if String_Length (The_String.Value) > 0 then ! String_To_Name_Buffer (The_String.Value); ! First_Switches.Increment_Last; ! First_Switches.Table (First_Switches.Last) := ! new String'(Name_Buffer (1 .. Name_Len)); ! end if; ! ! Current := The_String.Next; ! end loop; ! end case; end if; + end; + + -- Set up the environment variables ADA_INCLUDE_PATH and + -- ADA_OBJECTS_PATH. + + Setenv + (Name => Ada_Include_Path, + Value => Prj.Env.Ada_Include_Path (Project).all); + Setenv + (Name => Ada_Objects_Path, + Value => Prj.Env.Ada_Objects_Path + (Project, Including_Libraries => False).all); + + if The_Command = Bind or else The_Command = Link then + Change_Dir + (Get_Name_String + (Projects.Table (Project).Object_Directory)); + end if; + + if The_Command = Link then + + -- Add the default search directories, to be able to find + -- libgnat in call to MLib.Utl.Lib_Directory. + + Add_Default_Search_Dirs; + + declare + There_Are_Libraries : Boolean := False; + + begin + -- Check if there are library project files + + if MLib.Tgt.Libraries_Are_Supported then + Set_Libraries (Project, There_Are_Libraries); + end if; + + -- If there are, add the necessary additional switches + + if There_Are_Libraries then + + -- Add -L -lgnarl -lgnat -Wl,-rpath, + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-L" & MLib.Utl.Lib_Directory); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-lgnarl"); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-lgnat"); + + declare + Option : constant String_Access := + MLib.Tgt.Linker_Library_Path_Option + (MLib.Utl.Lib_Directory); + + begin + if Option /= null then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + Option; + end if; + end; + end if; + end; + end if; + end if; + + -- Gather all the arguments and invoke the executable + + declare + The_Args : Argument_List + (1 .. First_Switches.Last + Last_Switches.Last); + Arg_Num : Natural := 0; + begin + for J in 1 .. First_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := First_Switches.Table (J); end loop; ! for J in 1 .. Last_Switches.Last loop ! Arg_Num := Arg_Num + 1; ! The_Args (Arg_Num) := Last_Switches.Table (J); ! end loop; ! if Opt.Verbose_Mode then ! Output.Write_Str (Exec_Path.all); ! ! for Arg in The_Args'Range loop ! Output.Write_Char (' '); ! Output.Write_Str (The_Args (Arg).all); ! end loop; ! ! Output.Write_Eol; end if; My_Exit_Status ! := Exit_Status (Spawn (Exec_Path.all, The_Args)); ! raise Normal_Exit; end; ! end; exception when Error_Exit => diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatcmd.ads gcc-3.3/gcc/ada/gnatcmd.ads *** gcc-3.2.3/gcc/ada/gnatcmd.ads 2002-05-07 08:22:18.000000000 +0000 --- gcc-3.3/gcc/ada/gnatcmd.ads 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatdll.adb gcc-3.3/gcc/ada/gnatdll.adb *** gcc-3.2.3/gcc/ada/gnatdll.adb 2002-05-04 03:28:11.000000000 +0000 --- gcc-3.3/gcc/ada/gnatdll.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- 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,13 ---- -- -- -- 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- -- *************** with GNAT.OS_Lib; *** 37,44 **** with GNAT.Command_Line; with Gnatvsn; ! with MDLL.Files; ! with MDLL.Tools; procedure Gnatdll is --- 36,43 ---- with GNAT.Command_Line; with Gnatvsn; ! with MDLL.Fil; ! with MDLL.Utl; procedure Gnatdll is *************** procedure Gnatdll is *** 62,72 **** -- Check the context before runing any commands to build the library Syntax_Error : exception; Context_Error : exception; ! -- What are these for ??? Help : Boolean := False; ! -- What is this for ??? Version : constant String := Gnatvsn.Gnat_Version_String; -- Why should it be necessary to make a copy of this --- 61,75 ---- -- Check the context before runing any commands to build the library Syntax_Error : exception; + -- Raised when a syntax error is detected, in this case a usage info will + -- be displayed. + Context_Error : exception; ! -- Raised when some files (specifed on the command line) are missing to ! -- build the DLL. Help : Boolean := False; ! -- Help will be set to True the usage information is to be displayed. Version : constant String := Gnatvsn.Gnat_Version_String; -- Why should it be necessary to make a copy of this *************** procedure Gnatdll is *** 75,85 **** -- Default address for non relocatable DLL (Win32) Lib_Filename : Unbounded_String := Null_Unbounded_String; Def_Filename : Unbounded_String := Null_Unbounded_String; List_Filename : Unbounded_String := Null_Unbounded_String; DLL_Address : Unbounded_String := To_Unbounded_String (Default_DLL_Address); ! -- What are the above ??? Objects_Files : Argument_List_Access := Null_Argument_List_Access; -- List of objects to put inside the library --- 78,94 ---- -- Default address for non relocatable DLL (Win32) Lib_Filename : Unbounded_String := Null_Unbounded_String; + -- The DLL filename that will be created (.dll) + Def_Filename : Unbounded_String := Null_Unbounded_String; + -- The definition filename (.def) + List_Filename : Unbounded_String := Null_Unbounded_String; + -- The name of the file containing the objects file to put into the DLL + DLL_Address : Unbounded_String := To_Unbounded_String (Default_DLL_Address); ! -- The DLL's base address Objects_Files : Argument_List_Access := Null_Argument_List_Access; -- List of objects to put inside the library *************** procedure Gnatdll is *** 95,107 **** Bargs_Options : Argument_List_Access := Null_Argument_List_Access; -- GNAT linker and binder args options ! type Build_Mode_State is (Import_Lib, Dynamic_Lib, Nil); ! -- Comments needed ??? Build_Mode : Build_Mode_State := Nil; Must_Build_Relocatable : Boolean := True; ! Build_Import : Boolean := True; ! -- Comments needed ------------ -- Syntax -- --- 104,121 ---- Bargs_Options : Argument_List_Access := Null_Argument_List_Access; -- GNAT linker and binder args options ! type Build_Mode_State is (Import_Lib, Dynamic_Lib, Dynamic_Lib_Only, Nil); ! -- Import_Lib means only the .a file will be created, Dynamic_Lib means ! -- that both the DLL and the import library will be created. ! -- Dynamic_Lib_Only means that only the DLL will be created (no import ! -- library). Build_Mode : Build_Mode_State := Nil; + -- Will be set when parsing the command line. + Must_Build_Relocatable : Boolean := True; ! -- True means build a relocatable DLL, will be set to False if a ! -- non-relocatable DLL must be built. ------------ -- Syntax -- *************** procedure Gnatdll is *** 130,135 **** --- 144,151 ---- P (" -e file Definition file containing exports"); P (" -d file Put objects in the relocatable dynamic " & "library "); + P (" -b addr Set base address for the relocatable DLL"); + P (" default address is " & Default_DLL_Address); P (" -a[addr] Build non-relocatable DLL at address "); P (" if is not specified use " & Default_DLL_Address); *************** procedure Gnatdll is *** 159,174 **** use GNAT.Command_Line; procedure Add_File (Filename : in String); ! -- add one file to the list of file to handle procedure Add_Files_From_List (List_Filename : in String); ! -- add the files listed in List_Filename (one by line) to the list -- of file to handle - procedure Ali_To_Object_List; - -- for each ali file in Afiles set put a corresponding object file in - -- Ofiles set. - Max_Files : constant := 5_000; Max_Options : constant := 100; -- These are arbitrary limits, a better way will be to use linked list. --- 175,186 ---- use GNAT.Command_Line; procedure Add_File (Filename : in String); ! -- Add one file to the list of file to handle procedure Add_Files_From_List (List_Filename : in String); ! -- Add the files listed in List_Filename (one by line) to the list -- of file to handle Max_Files : constant := 5_000; Max_Options : constant := 100; -- These are arbitrary limits, a better way will be to use linked list. *************** procedure Gnatdll is *** 196,211 **** B : Positive := Bopts'First; -- A list of -bargs options (B is next entry to be used) -------------- -- Add_File -- -------------- procedure Add_File (Filename : in String) is begin ! -- others files are to be put inside the dynamic library ! -- ??? this makes no sense, should it be "Other files ..." ! ! if Files.Is_Ali (Filename) then Check (Filename); --- 208,223 ---- B : Positive := Bopts'First; -- A list of -bargs options (B is next entry to be used) + Build_Import : Boolean := True; + -- Set to Fals if option -n if specified (no-import). + -------------- -- Add_File -- -------------- procedure Add_File (Filename : in String) is begin ! if Fil.Is_Ali (Filename) then Check (Filename); *************** procedure Gnatdll is *** 215,221 **** Afiles (A) := new String'(Filename); A := A + 1; ! elsif Files.Is_Obj (Filename) then Check (Filename); --- 227,233 ---- Afiles (A) := new String'(Filename); A := A + 1; ! elsif Fil.Is_Obj (Filename) then Check (Filename); *************** procedure Gnatdll is *** 253,270 **** Text_IO.Close (File); end Add_Files_From_List; - ------------------------ - -- Ali_To_Object_List -- - ------------------------ - - procedure Ali_To_Object_List is - begin - for K in 1 .. A - 1 loop - Ofiles (O) := new String'(Files.Ext_To (Afiles (K).all, "o")); - O := O + 1; - end loop; - end Ali_To_Object_List; - -- Start of processing for Parse_Command_Line begin --- 265,270 ---- *************** procedure Gnatdll is *** 273,279 **** -- scan gnatdll switches loop ! case Getopt ("g h v q k a? d: e: l: n I:") is when ASCII.Nul => exit; --- 273,279 ---- -- scan gnatdll switches loop ! case Getopt ("g h v q k a? b: d: e: l: n I:") is when ASCII.Nul => exit; *************** procedure Gnatdll is *** 326,331 **** --- 326,337 ---- Must_Build_Relocatable := False; + when 'b' => + + DLL_Address := To_Unbounded_String (Parameter); + + Must_Build_Relocatable := True; + when 'e' => Def_Filename := To_Unbounded_String (Parameter); *************** procedure Gnatdll is *** 338,344 **** if Def_Filename = Null_Unbounded_String then Def_Filename := To_Unbounded_String ! (Files.Ext_To (Parameter, "def")); end if; Build_Mode := Dynamic_Lib; --- 344,350 ---- if Def_Filename = Null_Unbounded_String then Def_Filename := To_Unbounded_String ! (Fil.Ext_To (Parameter, "def")); end if; Build_Mode := Dynamic_Lib; *************** procedure Gnatdll is *** 419,424 **** --- 425,441 ---- "nothing to do."); end if; + -- -n option but no file specified + + if not Build_Import + and then A = Afiles'First + and then O = Ofiles'First + then + Exceptions.Raise_Exception + (Syntax_Error'Identity, + "-n specified but there are no objects to build the library."); + end if; + -- Check if we want to build an import library (option -e and -- no file specified) *************** procedure Gnatdll is *** 429,434 **** --- 446,457 ---- Build_Mode := Import_Lib; end if; + -- Check if only a dynamic library must be built. + + if Build_Mode = Dynamic_Lib and then not Build_Import then + Build_Mode := Dynamic_Lib_Only; + end if; + if O /= Ofiles'First then Objects_Files := new OS_Lib.Argument_List'(Ofiles (1 .. O - 1)); end if; *************** begin *** 495,501 **** Text_IO.New_Line; end if; ! MDLL.Tools.Locate; if Help or else (MDLL.Verbose and then Ada.Command_Line.Argument_Count = 1) --- 518,524 ---- Text_IO.New_Line; end if; ! MDLL.Utl.Locate; if Help or else (MDLL.Verbose and then Ada.Command_Line.Argument_Count = 1) *************** begin *** 521,528 **** To_String (Lib_Filename), To_String (Def_Filename), To_String (DLL_Address), ! Build_Import, ! Must_Build_Relocatable); when Nil => null; --- 544,564 ---- To_String (Lib_Filename), To_String (Def_Filename), To_String (DLL_Address), ! Build_Import => True, ! Relocatable => Must_Build_Relocatable); ! ! when Dynamic_Lib_Only => ! MDLL.Build_Dynamic_Library ! (Objects_Files.all, ! Ali_Files.all, ! Options.all, ! Bargs_Options.all, ! Largs_Options.all, ! To_String (Lib_Filename), ! To_String (Def_Filename), ! To_String (DLL_Address), ! Build_Import => False, ! Relocatable => Must_Build_Relocatable); when Nil => null; diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatfind.adb gcc-3.3/gcc/ada/gnatfind.adb *** gcc-3.2.3/gcc/ada/gnatfind.adb 2002-05-04 03:28:11.000000000 +0000 --- gcc-3.3/gcc/ada/gnatfind.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1998-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,13 ---- -- -- -- B o d y -- -- -- -- -- ! -- Copyright (C) 1998-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- -- *************** *** 23,35 **** -- -- ------------------------------------------------------------------------------ ! with Xr_Tabls; ! with Xref_Lib; use Xref_Lib; ! with Ada.Text_IO; ! with GNAT.Command_Line; with Gnatvsn; ! with Osint; with Ada.Strings.Fixed; use Ada.Strings.Fixed; --------------- -- Gnatfind -- --- 22,38 ---- -- -- ------------------------------------------------------------------------------ ! with Xr_Tabls; use Xr_Tabls; ! with Xref_Lib; use Xref_Lib; ! with Osint; use Osint; ! with Types; use Types; ! with Gnatvsn; ! with Opt; ! with Ada.Strings.Fixed; use Ada.Strings.Fixed; + with Ada.Text_IO; use Ada.Text_IO; + with GNAT.Command_Line; use GNAT.Command_Line; --------------- -- Gnatfind -- *************** procedure Gnatfind is *** 69,83 **** procedure Parse_Cmd_Line is begin loop ! case GNAT.Command_Line.Getopt ("a aI: aO: d e f g h I: p: r s t") is when ASCII.NUL => exit; when 'a' => if GNAT.Command_Line.Full_Switch = "a" then Read_Only := True; elsif GNAT.Command_Line.Full_Switch = "aI" then Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); else Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); end if; --- 72,91 ---- procedure Parse_Cmd_Line is begin loop ! case ! GNAT.Command_Line.Getopt ! ("a aI: aO: d e f g h I: nostdinc nostdlib p: r s t -RTS=") ! is when ASCII.NUL => exit; when 'a' => if GNAT.Command_Line.Full_Switch = "a" then Read_Only := True; + elsif GNAT.Command_Line.Full_Switch = "aI" then Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + else Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); end if; *************** procedure Gnatfind is *** 101,109 **** --- 109,126 ---- Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + when 'n' => + if GNAT.Command_Line.Full_Switch = "nostdinc" then + Opt.No_Stdinc := True; + + elsif GNAT.Command_Line.Full_Switch = "nostlib" then + Opt.No_Stdlib := True; + end if; + when 'p' => declare S : constant String := GNAT.Command_Line.Parameter; + begin Prj_File_Length := S'Length; Prj_File (1 .. Prj_File_Length) := S; *************** procedure Gnatfind is *** 118,123 **** --- 135,173 ---- when 't' => Type_Tree := True; + -- Only switch starting with -- recognized is --RTS + + when '-' => + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, Include); + Lib_Path_Name : String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, Objects); + + begin + if Src_Path_Name /= null and then Lib_Path_Name /= null then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null and then Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + when others => Write_Usage; end case; *************** procedure Gnatfind is *** 128,133 **** --- 178,184 ---- loop declare S : constant String := GNAT.Command_Line.Get_Argument; + begin exit when S'Length = 0; *************** procedure Gnatfind is *** 145,151 **** -- Next arguments are the files to search else ! Add_File (S); Wide_Search := False; Nb_File := Nb_File + 1; end if; --- 196,202 ---- -- Next arguments are the files to search else ! Add_Xref_File (S); Wide_Search := False; Nb_File := Nb_File + 1; end if; *************** procedure Gnatfind is *** 160,166 **** when GNAT.Command_Line.Invalid_Parameter => Ada.Text_IO.Put_Line ("Parameter missing for : " ! & GNAT.Command_Line.Parameter); Write_Usage; when Xref_Lib.Invalid_Argument => --- 211,217 ---- when GNAT.Command_Line.Invalid_Parameter => Ada.Text_IO.Put_Line ("Parameter missing for : " ! & GNAT.Command_Line.Full_Switch); Write_Usage; when Xref_Lib.Invalid_Argument => *************** procedure Gnatfind is *** 173,183 **** ----------------- procedure Write_Usage is - use Ada.Text_IO; - begin Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String ! & " Copyright 1998-2001, Ada Core Technologies Inc."); Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] " & "[file1 file2 ...]"); New_Line; --- 224,232 ---- ----------------- procedure Write_Usage is begin Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String ! & " Copyright 1998-2002, Ada Core Technologies Inc."); Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] " & "[file1 file2 ...]"); New_Line; *************** procedure Gnatfind is *** 193,220 **** & "references. This parameters are optional"); New_Line; Put_Line ("gnatfind switches:"); ! Put_Line (" -a Consider all files, even when the ali file is " & "readonly"); ! Put_Line (" -aIdir Specify source files search path"); ! Put_Line (" -aOdir Specify library/object files search path"); ! Put_Line (" -d Output derived type information"); ! Put_Line (" -e Use the full regular expression set for pattern"); ! Put_Line (" -f Output full path name"); ! Put_Line (" -g Output information only for global symbols"); ! Put_Line (" -Idir Like -aIdir -aOdir"); ! Put_Line (" -p file Use file as the default project file"); ! Put_Line (" -r Find all references (default to find declaration" & " only)"); ! Put_Line (" -s Print source line"); ! Put_Line (" -t Print type hierarchy"); New_Line; raise Usage_Error; end Write_Usage; ! begin ! Osint.Initialize (Osint.Compiler); Parse_Cmd_Line; if not Have_Entity then --- 242,276 ---- & "references. This parameters are optional"); New_Line; Put_Line ("gnatfind switches:"); ! Put_Line (" -a Consider all files, even when the ali file is " & "readonly"); ! Put_Line (" -aIdir Specify source files search path"); ! Put_Line (" -aOdir Specify library/object files search path"); ! Put_Line (" -d Output derived type information"); ! Put_Line (" -e Use the full regular expression set for " ! & "pattern"); ! Put_Line (" -f Output full path name"); ! Put_Line (" -g Output information only for global symbols"); ! Put_Line (" -Idir Like -aIdir -aOdir"); ! Put_Line (" -nostdinc Don't look for sources in the system default" ! & " directory"); ! Put_Line (" -nostdlib Don't look for library files in the system" ! & " default directory"); ! Put_Line (" --RTS=dir specify the default source and object search" ! & " path"); ! Put_Line (" -p file Use file as the default project file"); ! Put_Line (" -r Find all references (default to find declaration" & " only)"); ! Put_Line (" -s Print source line"); ! Put_Line (" -t Print type hierarchy"); New_Line; raise Usage_Error; end Write_Usage; ! -- Start of processing for Gnatfind + begin Parse_Cmd_Line; if not Have_Entity then diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatkr.adb gcc-3.3/gcc/ada/gnatkr.adb *** gcc-3.2.3/gcc/ada/gnatkr.adb 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatkr.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** *** 28,39 **** with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; - with Gnatvsn; with Krunch; with System.IO; use System.IO; procedure Gnatkr is - pragma Ident (Gnatvsn.Gnat_Version_String); Count : Natural; Maxlen : Integer; --- 27,36 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatkr.ads gcc-3.3/gcc/ada/gnatkr.ads *** gcc-3.2.3/gcc/ada/gnatkr.ads 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatkr.ads 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatlbr.adb gcc-3.3/gcc/ada/gnatlbr.adb *** gcc-3.2.3/gcc/ada/gnatlbr.adb 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatlbr.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- Copyright (C) 1997-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,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- -- *************** *** 46,59 **** with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; - with Gnatvsn; use Gnatvsn; with Interfaces.C_Streams; use Interfaces.C_Streams; with Osint; use Osint; with Sdefault; use Sdefault; with System; procedure GnatLbr is - pragma Ident (Gnat_Version_String); type Lib_Mode is (None, Create, Set, Delete); Next_Arg : Integer; --- 45,56 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatlink.adb gcc-3.3/gcc/ada/gnatlink.adb *** gcc-3.2.3/gcc/ada/gnatlink.adb 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatlink.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.2.10.1 $ -- -- ! -- 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,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- -- *************** *** 28,39 **** --- 27,43 ---- -- Gnatlink usage: please consult the gnat documentation + with Ada.Exceptions; use Ada.Exceptions; + with ALI; use ALI; with Gnatvsn; use Gnatvsn; with Hostparm; + with Namet; use Namet; with Osint; use Osint; with Output; use Output; + with Switch; use Switch; with System; use System; with Table; + with Types; with Ada.Command_Line; use Ada.Command_Line; with GNAT.OS_Lib; use GNAT.OS_Lib; *************** with Interfaces.C_Streams; use Interface *** 41,48 **** procedure Gnatlink is - pragma Ident (Gnat_Version_String); - package Gcc_Linker_Options is new Table.Table ( Table_Component_Type => String_Access, Table_Index_Type => Integer, --- 45,50 ---- *************** procedure Gnatlink is *** 97,102 **** --- 99,114 ---- -- file. Only application objects are collected there (see details in -- Linker_Objects table comments) + package Binder_Options_From_ALI is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, -- equals low bound of Argument_List for Spawn + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Binder_Options_From_ALI"); + -- This table collects the switches from the ALI file of the main + -- subprogram. + package Binder_Options is new Table.Table ( Table_Component_Type => String_Access, Table_Index_Type => Integer, *************** procedure Gnatlink is *** 139,144 **** --- 151,158 ---- Ada_Bind_File : Boolean := True; -- Set to True if bind file is generated in Ada + Standard_Gcc : Boolean := True; + Compile_Bind_File : Boolean := True; -- Set to False if bind file is not to be compiled *************** procedure Gnatlink is *** 250,279 **** Next_Arg : Integer; begin - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-c"); - - -- If the main program is in Ada it is compiled with the following - -- switches: - - -- -gnatA stops reading gnat.adc, since we don't know what - -- pagmas would work, and we do not need it anyway. - - -- -gnatWb allows brackets coding for wide characters - - -- -gnatiw allows wide characters in identifiers. This is needed - -- because bindgen uses brackets encoding for all upper - -- half and wide characters in identifier names. - - if Ada_Bind_File then - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-gnatA"); - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-gnatWb"); - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-gnatiw"); - end if; - -- Loop through arguments of gnatlink command Next_Arg := 1; --- 264,269 ---- *************** procedure Gnatlink is *** 288,296 **** -- We definitely need section by section comments here ??? ! if Arg'Length /= 0 ! and then (Arg (1) = Switch_Character or else Arg (1) = '-') ! then if Arg'Length > 4 and then Arg (2 .. 5) = "gnat" then --- 278,284 ---- -- We definitely need section by section comments here ??? ! if Arg'Length /= 0 and then Arg (1) = '-' then if Arg'Length > 4 and then Arg (2 .. 5) = "gnat" then *************** procedure Gnatlink is *** 440,445 **** --- 428,434 ---- begin Gcc := new String'(Program_Args.all (1).all); + Standard_Gcc := False; -- Set appropriate flags for switches passed *************** procedure Gnatlink is *** 449,458 **** AF : Integer := Arg'First; begin ! if Arg'Length /= 0 ! and then (Arg (AF) = Switch_Character ! or else Arg (AF) = '-') ! then if Arg (AF + 1) = 'g' and then (Arg'Length = 2 or else Arg (AF + 2) in '0' .. '3' --- 438,444 ---- AF : Integer := Arg'First; begin ! if Arg'Length /= 0 and then Arg (AF) = '-' then if Arg (AF + 1) = 'g' and then (Arg'Length = 2 or else Arg (AF + 2) in '0' .. '3' *************** procedure Gnatlink is *** 765,895 **** if Next_Line (Nfirst .. Nlast) /= End_Info then loop ! -- Add binder options only if not already set on the command ! -- line. This rule is a way to control the linker options order. ! ! if not Is_Option_Present ! (Next_Line (Nfirst .. Nlast)) ! then ! if Next_Line (Nfirst .. Nlast) = "-static" then ! GNAT_Static := True; ! ! elsif Next_Line (Nfirst .. Nlast) = "-shared" then ! GNAT_Shared := True; ! else ! if Nlast > Nfirst + 2 and then ! Next_Line (Nfirst .. Nfirst + 1) = "-L" ! then ! -- Construct a library search path for use later ! -- to locate static gnatlib libraries. ! if Libpath.Last > 1 then ! Libpath.Increment_Last; ! Libpath.Table (Libpath.Last) := Path_Separator; ! end if; ! for I in Nfirst + 2 .. Nlast loop ! Libpath.Increment_Last; ! Libpath.Table (Libpath.Last) := Next_Line (I); ! end loop; ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) := ! new String'(Next_Line (Nfirst .. Nlast)); ! elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" ! or else Next_Line (Nfirst .. Nlast) = "-lgnarl" ! or else Next_Line (Nfirst .. Nlast) = "-lgnat" ! then ! -- Given a Gnat standard library, search the ! -- library path to find the library location ! declare ! File_Path : String_Access; ! Object_Lib_Extension : constant String := ! Value ! (Object_Library_Ext_Ptr); ! File_Name : String := ! "lib" & ! Next_Line (Nfirst + 2 .. Nlast) & ! Object_Lib_Extension; ! begin ! File_Path := ! Locate_Regular_File ! (File_Name, ! String (Libpath.Table (1 .. Libpath.Last))); ! if File_Path /= null then ! if GNAT_Static then ! -- If static gnatlib found, explicitly ! -- specify to overcome possible linker ! -- default usage of shared version. ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) := ! new String'(File_Path.all); ! elsif GNAT_Shared then ! -- If shared gnatlib desired, add the ! -- appropriate system specific switch ! -- so that it can be located at runtime. ! declare ! Run_Path_Opt : constant String := ! Value ! (Run_Path_Option_Ptr); ! begin ! if Run_Path_Opt'Length /= 0 then ! -- Output the system specific linker ! -- command that allows the image ! -- activator to find the shared library ! -- at runtime. ! Linker_Options.Increment_Last; ! Linker_Options.Table ! (Linker_Options.Last) := ! new String'(Run_Path_Opt ! & File_Path ! (1 .. File_Path'Length ! - File_Name'Length)); ! end if; Linker_Options.Increment_Last; ! Linker_Options.Table ! (Linker_Options.Last) := ! new String'(Next_Line ! (Nfirst .. Nlast)); ! ! end; ! end if; ! else ! -- If gnatlib library not found, then ! -- add it anyway in case some other ! -- mechanimsm may find it. ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) := ! new String'(Next_Line (Nfirst .. Nlast)); ! end if; ! end; ! else ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) := ! new String'(Next_Line (Nfirst .. Nlast)); ! end if; end if; end if; --- 751,866 ---- if Next_Line (Nfirst .. Nlast) /= End_Info then loop ! if Next_Line (Nfirst .. Nlast) = "-static" then ! GNAT_Static := True; ! elsif Next_Line (Nfirst .. Nlast) = "-shared" then ! GNAT_Shared := True; ! -- Add binder options only if not already set on the command ! -- line. This rule is a way to control the linker options order. ! elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then ! if Nlast > Nfirst + 2 and then ! Next_Line (Nfirst .. Nfirst + 1) = "-L" ! then ! -- Construct a library search path for use later ! -- to locate static gnatlib libraries. ! if Libpath.Last > 1 then ! Libpath.Increment_Last; ! Libpath.Table (Libpath.Last) := Path_Separator; ! end if; ! for I in Nfirst + 2 .. Nlast loop ! Libpath.Increment_Last; ! Libpath.Table (Libpath.Last) := Next_Line (I); ! end loop; ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) := ! new String'(Next_Line (Nfirst .. Nlast)); ! elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" ! or else Next_Line (Nfirst .. Nlast) = "-lgnarl" ! or else Next_Line (Nfirst .. Nlast) = "-lgnat" ! then ! -- Given a Gnat standard library, search the ! -- library path to find the library location ! declare ! File_Path : String_Access; ! Object_Lib_Extension : constant String := ! Value (Object_Library_Ext_Ptr); ! File_Name : String := "lib" & ! Next_Line (Nfirst + 2 .. Nlast) & Object_Lib_Extension; ! begin ! File_Path := ! Locate_Regular_File (File_Name, ! String (Libpath.Table (1 .. Libpath.Last))); ! if File_Path /= null then ! if GNAT_Static then ! -- If static gnatlib found, explicitly ! -- specify to overcome possible linker ! -- default usage of shared version. ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) := ! new String'(File_Path.all); ! elsif GNAT_Shared then ! -- If shared gnatlib desired, add the ! -- appropriate system specific switch ! -- so that it can be located at runtime. ! declare ! Run_Path_Opt : constant String := ! Value (Run_Path_Option_Ptr); ! begin ! if Run_Path_Opt'Length /= 0 then ! -- Output the system specific linker ! -- command that allows the image ! -- activator to find the shared library ! -- at runtime. Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) ! := new String'(Run_Path_Opt ! & File_Path ! (1 .. File_Path'Length ! - File_Name'Length)); ! end if; ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) ! := new String'(Next_Line (Nfirst .. Nlast)); ! end; ! end if; ! else ! -- If gnatlib library not found, then ! -- add it anyway in case some other ! -- mechanimsm may find it. ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) ! := new String'(Next_Line (Nfirst .. Nlast)); ! end if; ! end; ! else ! Linker_Options.Increment_Last; ! Linker_Options.Table (Linker_Options.Last) ! := new String'(Next_Line (Nfirst .. Nlast)); end if; end if; *************** procedure Gnatlink is *** 897,904 **** exit when Next_Line (Nfirst .. Nlast) = End_Info; if Ada_Bind_File then ! Next_Line (Nfirst .. Nlast - 8) := ! Next_Line (Nfirst + 8 .. Nlast); Nlast := Nlast - 8; end if; end loop; --- 868,875 ---- exit when Next_Line (Nfirst .. Nlast) = End_Info; if Ada_Bind_File then ! Next_Line (Nfirst .. Nlast - 8) ! := Next_Line (Nfirst + 8 .. Nlast); Nlast := Nlast - 8; end if; end loop; *************** procedure Gnatlink is *** 966,972 **** -- Start of processing for Gnatlink begin - if Argument_Count = 0 then Write_Usage; Exit_Program (E_Fatal); --- 937,942 ---- *************** begin *** 981,986 **** --- 951,986 ---- Process_Args; + -- We always compile with -c + + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-c"); + + -- If the main program is in Ada it is compiled with the following + -- switches: + + -- -gnatA stops reading gnat.adc, since we don't know what + -- pagmas would work, and we do not need it anyway. + + -- -gnatWb allows brackets coding for wide characters + + -- -gnatiw allows wide characters in identifiers. This is needed + -- because bindgen uses brackets encoding for all upper + -- half and wide characters in identifier names. + + if Ada_Bind_File then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatA"); + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatWb"); + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatiw"); + end if; + -- Locate all the necessary programs and verify required files are present Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); *************** begin *** 999,1011 **** if not Is_Regular_File (Ali_File_Name.all) then Exit_With_Error (Ali_File_Name.all & " not found."); end if; if Verbose_Mode then Write_Eol; Write_Str ("GNATLINK "); Write_Str (Gnat_Version_String); ! Write_Str (" Copyright 1996-2001 Free Software Foundation, Inc."); Write_Eol; end if; --- 999,1059 ---- if not Is_Regular_File (Ali_File_Name.all) then Exit_With_Error (Ali_File_Name.all & " not found."); + + -- Read the ALI file of the main subprogram if the binder generated + -- file is in Ada, it need to be compiled and no --GCC= switch has + -- been specified. Fetch the back end switches from this ALI file and use + -- these switches to compile the binder generated file + + elsif Ada_Bind_File + and then Compile_Bind_File + and then Standard_Gcc + then + -- Do some initializations + + Initialize_ALI; + Namet.Initialize; + Name_Len := Ali_File_Name'Length; + Name_Buffer (1 .. Name_Len) := Ali_File_Name.all; + + declare + use Types; + F : constant File_Name_Type := Name_Find; + T : Text_Buffer_Ptr; + A : ALI_Id; + + begin + -- Osint.Add_Default_Search_Dirs; + -- Load the ALI file + + T := Read_Library_Info (F, True); + + -- Read it + + A := Scan_ALI (F, T, False, False, False); + + if A /= No_ALI_Id then + for + Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg + .. Units.Table (ALIs.Table (A).First_Unit).Last_Arg + loop + -- Do not compile with the front end switches + + if not Is_Front_End_Switch (Args.Table (Index).all) then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) + := String_Access (Args.Table (Index)); + end if; + end loop; + end if; + end; end if; if Verbose_Mode then Write_Eol; Write_Str ("GNATLINK "); Write_Str (Gnat_Version_String); ! Write_Str (" Copyright 1996-2002 Free Software Foundation, Inc."); Write_Eol; end if; *************** begin *** 1129,1139 **** if Compile_Bind_File then Bind_Step : declare Success : Boolean; ! Args : Argument_List (1 .. Binder_Options.Last + 1); begin ! for J in Binder_Options.First .. Binder_Options.Last loop ! Args (J) := Binder_Options.Table (J); end loop; Args (Args'Last) := Binder_Body_Src_File; --- 1177,1193 ---- if Compile_Bind_File then Bind_Step : declare Success : Boolean; ! Args : Argument_List ! (1 .. Binder_Options_From_ALI.Last + Binder_Options.Last + 1); begin ! for J in 1 .. Binder_Options_From_ALI.Last loop ! Args (J) := Binder_Options_From_ALI.Table (J); ! end loop; ! ! for J in 1 .. Binder_Options.Last loop ! Args (Binder_Options_From_ALI.Last + J) := ! Binder_Options.Table (J); end loop; Args (Args'Last) := Binder_Body_Src_File; *************** begin *** 1346,1351 **** Exit_Program (E_Success); exception ! when others => Exit_With_Error ("INTERNAL ERROR. Please report."); end Gnatlink; --- 1400,1406 ---- Exit_Program (E_Success); exception ! when X : others => ! Write_Line (Exception_Information (X)); Exit_With_Error ("INTERNAL ERROR. Please report."); end Gnatlink; diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatlink.ads gcc-3.3/gcc/ada/gnatlink.ads *** gcc-3.2.3/gcc/ada/gnatlink.ads 2002-05-07 08:22:18.000000000 +0000 --- gcc-3.3/gcc/ada/gnatlink.ads 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1996 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatls.adb gcc-3.3/gcc/ada/gnatls.adb *** gcc-3.2.3/gcc/ada/gnatls.adb 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatls.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** with ALI; use ALI; *** 30,54 **** with ALI.Util; use ALI.Util; with Binderr; use Binderr; with Butil; use Butil; - with Csets; with Fname; use Fname; with Gnatvsn; use Gnatvsn; with GNAT.OS_Lib; use GNAT.OS_Lib; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; ! with Prj; use Prj; ! with Prj.Pars; use Prj.Pars; ! with Prj.Env; ! with Prj.Ext; use Prj.Ext; ! with Prj.Util; use Prj.Util; ! with Snames; use Snames; ! with Stringt; use Stringt; with Types; use Types; procedure Gnatls is - pragma Ident (Gnat_Version_String); Max_Column : constant := 80; --- 29,46 ---- with ALI.Util; use ALI.Util; with Binderr; use Binderr; with Butil; use Butil; with Fname; use Fname; with Gnatvsn; use Gnatvsn; with GNAT.OS_Lib; use GNAT.OS_Lib; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; + with Osint.L; use Osint.L; with Output; use Output; ! with Targparm; use Targparm; with Types; use Types; procedure Gnatls is Max_Column : constant := 80; *************** procedure Gnatls is *** 66,71 **** --- 58,64 ---- Value : String_Access; Next : Dir_Ref; end record; + -- ??? comment needed First_Source_Dir : Dir_Ref; Last_Source_Dir : Dir_Ref; *************** procedure Gnatls is *** 91,100 **** -- When True, lines are too long for multi-column output and each -- item of information is on a different line. - Project_File : String_Access; - Project : Prj.Project_Id; - Current_Verbosity : Prj.Verbosity := Prj.Default; - Selective_Output : Boolean := False; Print_Usage : Boolean := False; Print_Unit : Boolean := True; --- 84,89 ---- *************** procedure Gnatls is *** 144,153 **** function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id; -- Give the Sdep entry corresponding to the unit U in ali record A. - function Index (Char : Character; Str : String) return Natural; - -- Returns the first occurrence of Char in Str. - -- Returns 0 if Char is not in Str. - procedure Output_Object (O : File_Name_Type); -- Print out the name of the object when requested --- 133,138 ---- *************** procedure Gnatls is *** 246,255 **** Write_Eol; Error_Msg ("wrong ALI format, can't find dependency line for & in %"); Exit_Program (E_Fatal); - - -- Not needed since we exit the program but avoids compiler warning - - raise Program_Error; end Corresponding_Sdep_Entry; ------------------------- --- 231,236 ---- *************** procedure Gnatls is *** 319,328 **** end if; Source_Start := Unit_End + 1; if Source_Start > Spaces'Last then Source_Start := Spaces'Last; end if; ! Source_End := Source_Start - 1; if Print_Source then Source_End := Source_Start + Max_Src_Length; --- 300,311 ---- end if; Source_Start := Unit_End + 1; + if Source_Start > Spaces'Last then Source_Start := Spaces'Last; end if; ! ! Source_End := Source_Start - 1; if Print_Source then Source_End := Source_Start + Max_Src_Length; *************** procedure Gnatls is *** 370,401 **** end if; end Find_Status; - ----------- - -- Index -- - ----------- - - function Index (Char : Character; Str : String) return Natural is - begin - for Index in Str'Range loop - if Str (Index) = Char then - return Index; - end if; - end loop; - - return 0; - end Index; - ------------------- -- Output_Object -- ------------------- procedure Output_Object (O : File_Name_Type) is Object_Name : String_Access; begin if Print_Object then Get_Name_String (O); Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); Write_Str (Object_Name.all); if Print_Source or else Print_Unit then if Too_Long then Write_Eol; --- 353,371 ---- end if; end Find_Status; ------------------- -- Output_Object -- ------------------- procedure Output_Object (O : File_Name_Type) is Object_Name : String_Access; + begin if Print_Object then Get_Name_String (O); Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); Write_Str (Object_Name.all); + if Print_Source or else Print_Unit then if Too_Long then Write_Eol; *************** procedure Gnatls is *** 611,714 **** return; end if; ! if Argv (1) = Switch_Character or else Argv (1) = '-' then if Argv'Length = 1 then Fail ("switch character cannot be followed by a blank"); ! -- -I- elsif Argv (2 .. Argv'Last) = "I-" then Opt.Look_In_Primary_Dir := False; ! -- Forbid -?- or -??- where ? is any character elsif (Argv'Length = 3 and then Argv (3) = '-') or else (Argv'Length = 4 and then Argv (4) = '-') then Fail ("Trailing ""-"" at the end of ", Argv, " forbidden."); ! -- -Idir elsif Argv (2) = 'I' then Add_Source_Dir (Argv (3 .. Argv'Last), And_Save); Add_Lib_Dir (Argv (3 .. Argv'Last), And_Save); ! -- -aIdir (to gcc this is like a -I switch) elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then Add_Source_Dir (Argv (4 .. Argv'Last), And_Save); ! -- -aOdir elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save); ! -- -aLdir (to gnatbind this is like a -aO switch) elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save); ! -- -vPx ! ! elsif Argv'Length = 4 and then Argv (2 .. 3) = "vP" then ! case Argv (4) is ! when '0' => ! Current_Verbosity := Prj.Default; ! when '1' => ! Current_Verbosity := Prj.Medium; ! when '2' => ! Current_Verbosity := Prj.High; ! when others => ! null; ! end case; ! ! -- -Pproject_file ! ! elsif Argv'Length >= 3 and then Argv (2) = 'P' then ! if Project_File /= null then ! Fail (Argv & ": second project file forbidden (first is """ & ! Project_File.all & """)"); ! else ! Project_File := new String'(Argv (3 .. Argv'Last)); ! end if; ! ! -- -Xexternal=value ! ! elsif Argv'Length >= 5 and then Argv (2) = 'X' then ! declare ! Equal_Pos : constant Natural := ! Index ('=', Argv (3 .. Argv'Last)); ! begin ! if Equal_Pos >= 4 and then ! Equal_Pos /= Argv'Last then ! Add (External_Name => Argv (3 .. Equal_Pos - 1), ! Value => Argv (Equal_Pos + 1 .. Argv'Last)); ! else ! Fail (Argv & " is not a valid external assignment."); ! end if; ! end; elsif Argv (2 .. Argv'Last) = "nostdinc" then Opt.No_Stdinc := True; elsif Argv'Length = 2 then case Argv (2) is ! when 'a' => Also_Predef := True; ! when 'h' => Print_Usage := True; when 'u' => Reset_Print; Print_Unit := True; when 's' => Reset_Print; Print_Source := True; when 'o' => Reset_Print; Print_Object := True; ! when 'v' => Verbose_Mode := True; ! when 'd' => Dependable := True; when others => null; end case; end if; ! -- If not a switch it must be a file name else ! Set_Main_File_Name (Argv); end if; end Scan_Ls_Arg; --- 581,699 ---- return; end if; ! if Argv (1) = '-' then if Argv'Length = 1 then Fail ("switch character cannot be followed by a blank"); ! -- Processing for -I- elsif Argv (2 .. Argv'Last) = "I-" then Opt.Look_In_Primary_Dir := False; ! -- Forbid -?- or -??- where ? is any character elsif (Argv'Length = 3 and then Argv (3) = '-') or else (Argv'Length = 4 and then Argv (4) = '-') then Fail ("Trailing ""-"" at the end of ", Argv, " forbidden."); ! -- Processing for -Idir elsif Argv (2) = 'I' then Add_Source_Dir (Argv (3 .. Argv'Last), And_Save); Add_Lib_Dir (Argv (3 .. Argv'Last), And_Save); ! -- Processing for -aIdir (to gcc this is like a -I switch) elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then Add_Source_Dir (Argv (4 .. Argv'Last), And_Save); ! -- Processing for -aOdir elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save); ! -- Processing for -aLdir (to gnatbind this is like a -aO switch) elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save); ! -- Processing for -nostdinc elsif Argv (2 .. Argv'Last) = "nostdinc" then Opt.No_Stdinc := True; + -- Processing for one character switches + elsif Argv'Length = 2 then case Argv (2) is ! when 'a' => Also_Predef := True; ! when 'h' => Print_Usage := True; when 'u' => Reset_Print; Print_Unit := True; when 's' => Reset_Print; Print_Source := True; when 'o' => Reset_Print; Print_Object := True; ! when 'v' => Verbose_Mode := True; ! when 'd' => Dependable := True; ! when others => null; end case; + + -- Processing for --RTS=path + + elsif Argv (1 .. 5) = "--RTS" then + + if Argv (6) /= '=' or else + (Argv (6) = '=' + and then Argv'Length = 6) + then + Osint.Fail ("missing path for --RTS"); + + else + -- Valid --RTS switch + + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : String_Ptr := + String_Ptr + (Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Include)); + Lib_Path_Name : String_Ptr := + String_Ptr + (Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Objects)); + + begin + if Src_Path_Name /= null + and then Lib_Path_Name /= null + then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + end if; end if; ! -- If not a switch, it must be a file name else ! Add_File (Argv); end if; end Scan_Ls_Arg; *************** procedure Gnatls is *** 717,730 **** ----------- procedure Usage is - procedure Write_Switch_Char; - -- Write two spaces followed by appropriate switch character - - procedure Write_Switch_Char is - begin - Write_Str (" "); - Write_Char (Switch_Character); - end Write_Switch_Char; -- Start of processing for Usage --- 702,707 ---- *************** procedure Gnatls is *** 744,838 **** -- Line for -a ! Write_Switch_Char; ! Write_Str ("a also output relevant predefined units"); Write_Eol; -- Line for -u ! Write_Switch_Char; ! Write_Str ("u output only relevant unit names"); Write_Eol; -- Line for -h ! Write_Switch_Char; ! Write_Str ("h output this help message"); Write_Eol; -- Line for -s ! Write_Switch_Char; ! Write_Str ("s output only relevant source names"); Write_Eol; -- Line for -o ! Write_Switch_Char; ! Write_Str ("o output only relevant object names"); Write_Eol; -- Line for -d ! Write_Switch_Char; ! Write_Str ("d output sources on which specified units depend"); Write_Eol; -- Line for -v ! Write_Switch_Char; ! Write_Str ("v verbose output, full path and unit information"); Write_Eol; Write_Eol; -- Line for -aI switch ! Write_Switch_Char; ! Write_Str ("aIdir specify source files search path"); Write_Eol; -- Line for -aO switch ! Write_Switch_Char; ! Write_Str ("aOdir specify object files search path"); Write_Eol; -- Line for -I switch ! Write_Switch_Char; ! Write_Str ("Idir like -aIdir -aOdir"); Write_Eol; -- Line for -I- switch ! Write_Switch_Char; ! Write_Str ("I- do not look for sources & object files"); Write_Str (" in the default directory"); Write_Eol; ! -- Line for -vPx ! ! Write_Switch_Char; ! Write_Str ("vPx verbosity for project file (0, 1 or 2)"); ! Write_Eol; ! ! -- Line for -Pproject_file ! ! Write_Switch_Char; ! Write_Str ("Pprj use a project file prj"); ! Write_Eol; ! ! -- Line for -Xexternal=value ! Write_Switch_Char; ! Write_Str ("Xext=val specify an external value."); Write_Eol; ! -- Line for -nostdinc ! Write_Switch_Char; ! Write_Str ("nostdinc do not look for source files"); ! Write_Str (" in the system default directory"); Write_Eol; -- File Status explanation --- 721,791 ---- -- Line for -a ! Write_Str (" -a also output relevant predefined units"); Write_Eol; -- Line for -u ! Write_Str (" -u output only relevant unit names"); Write_Eol; -- Line for -h ! Write_Str (" -h output this help message"); Write_Eol; -- Line for -s ! Write_Str (" -s output only relevant source names"); Write_Eol; -- Line for -o ! Write_Str (" -o output only relevant object names"); Write_Eol; -- Line for -d ! Write_Str (" -d output sources on which specified units depend"); Write_Eol; -- Line for -v ! Write_Str (" -v verbose output, full path and unit information"); Write_Eol; Write_Eol; -- Line for -aI switch ! Write_Str (" -aIdir specify source files search path"); Write_Eol; -- Line for -aO switch ! Write_Str (" -aOdir specify object files search path"); Write_Eol; -- Line for -I switch ! Write_Str (" -Idir like -aIdir -aOdir"); Write_Eol; -- Line for -I- switch ! Write_Str (" -I- do not look for sources & object files"); Write_Str (" in the default directory"); Write_Eol; ! -- Line for -nostdinc ! Write_Str (" -nostdinc do not look for source files"); ! Write_Str (" in the system default directory"); Write_Eol; ! -- Line for --RTS ! Write_Str (" --RTS=dir specify the default source and object search" ! & " path"); Write_Eol; -- File Status explanation *************** procedure Gnatls is *** 854,867 **** -- Start of processing for Gnatls begin - Osint.Initialize (Binder); - - Namet.Initialize; - Csets.Initialize; - - Snames.Initialize; - - Prj.Initialize; -- Use low level argument routines to avoid dragging in the secondary stack --- 807,812 ---- *************** begin *** 879,966 **** Next_Arg := Next_Arg + 1; end loop Scan_Args; - -- If a switch -P is used, parse the project file - - if Project_File /= null then - - Prj.Pars.Set_Verbosity (To => Current_Verbosity); - - Prj.Pars.Parse - (Project => Project, - Project_File_Name => Project_File.all); - - if Project = Prj.No_Project then - Fail ("""" & Project_File.all & """ processing failed"); - end if; - - -- Add the source directories and the object directories - -- to the searched directories. - - declare - procedure Register_Source_Dirs is new - Prj.Env.For_All_Source_Dirs (Add_Src_Search_Dir); - - procedure Register_Object_Dirs is new - Prj.Env.For_All_Object_Dirs (Add_Lib_Search_Dir); - - begin - Register_Source_Dirs (Project); - Register_Object_Dirs (Project); - end; - - -- Check if a package gnatls is in the project file and if there is - -- there is one, get the switches, if any, and scan them. - - declare - Data : Prj.Project_Data := Prj.Projects.Table (Project); - Pkg : Prj.Package_Id := - Prj.Util.Value_Of - (Name => Name_Gnatls, - In_Packages => Data.Decl.Packages); - Element : Package_Element; - Switches : Prj.Variable_Value; - Current : Prj.String_List_Id; - The_String : String_Element; - - begin - if Pkg /= No_Package then - Element := Packages.Table (Pkg); - Switches := - Prj.Util.Value_Of - (Variable_Name => Name_Switches, - In_Variables => Element.Decl.Attributes); - - case Switches.Kind is - when Prj.Undefined => - null; - - when Prj.Single => - if String_Length (Switches.Value) > 0 then - String_To_Name_Buffer (Switches.Value); - Scan_Ls_Arg - (Name_Buffer (1 .. Name_Len), - And_Save => False); - end if; - - when Prj.List => - Current := Switches.Values; - while Current /= Prj.Nil_String loop - The_String := String_Elements.Table (Current); - - if String_Length (The_String.Value) > 0 then - String_To_Name_Buffer (The_String.Value); - Scan_Ls_Arg - (Name_Buffer (1 .. Name_Len), - And_Save => False); - end if; - - Current := The_String.Next; - end loop; - end case; - end if; - end; - end if; - -- Add the source and object directories specified on the -- command line, if any, to the searched directories. --- 824,829 ---- *************** begin *** 974,984 **** First_Lib_Dir := First_Lib_Dir.Next; end loop; ! -- Finally, add the default directories. Osint.Add_Default_Search_Dirs; if Verbose_Mode then -- WARNING: the output of gnatls -v is used during the compilation -- and installation of GLADE to recreate sdefault.adb and locate --- 837,849 ---- First_Lib_Dir := First_Lib_Dir.Next; end loop; ! -- Finally, add the default directories and obtain target parameters Osint.Add_Default_Search_Dirs; if Verbose_Mode then + Namet.Initialize; + Targparm.Get_Target_Parameters; -- WARNING: the output of gnatls -v is used during the compilation -- and installation of GLADE to recreate sdefault.adb and locate *************** begin *** 987,994 **** Write_Eol; Write_Str ("GNATLS "); Write_Str (Gnat_Version_String); ! Write_Str (" Copyright 1997-2001 Free Software Foundation, Inc."); Write_Eol; Write_Eol; Write_Str ("Source Search Path:"); --- 852,864 ---- Write_Eol; Write_Str ("GNATLS "); + + if Targparm.High_Integrity_Mode_On_Target then + Write_Str ("Pro High Integrity "); + end if; + Write_Str (Gnat_Version_String); ! Write_Str (" Copyright 1997-2002 Free Software Foundation, Inc."); Write_Eol; Write_Eol; Write_Str ("Source Search Path:"); *************** begin *** 1042,1047 **** --- 912,918 ---- Exit_Program (E_Fatal); end if; + Namet.Initialize; Initialize_ALI; Initialize_ALI_Source; *************** begin *** 1131,1140 **** --- 1002,1013 ---- if Verbose_Mode then Write_Str (" "); Output_Source (D); + elsif Too_Long then Write_Str (" "); Output_Source (D); Write_Eol; + else Write_Str (Spaces (1 .. Source_Start - 2)); Output_Source (D); diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatls.ads gcc-3.3/gcc/ada/gnatls.ads *** gcc-3.2.3/gcc/ada/gnatls.ads 2002-05-07 08:22:18.000000000 +0000 --- gcc-3.3/gcc/ada/gnatls.ads 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatmain.adb gcc-3.3/gcc/ada/gnatmain.adb *** gcc-3.2.3/gcc/ada/gnatmain.adb 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatmain.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,594 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T M A I N -- - -- -- - -- B o d y -- - -- -- - -- $Revision: 1.2.12.1 $ - -- -- - -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- - -- -- - -- GNAT is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - with Csets; - with GNAT.Case_Util; - with GNAT.OS_Lib; use GNAT.OS_Lib; - with Namet; use Namet; - with Opt; - with Osint; use Osint; - with Output; use Output; - with Prj; use Prj; - with Prj.Env; - with Prj.Ext; use Prj.Ext; - with Prj.Pars; - with Prj.Util; use Prj.Util; - with Snames; use Snames; - with Stringt; use Stringt; - with Table; - with Types; use Types; - - procedure Gnatmain is - - Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; - Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; - - type Tool_Type is (None, List, Xref, Find, Stub, Make, Comp, Bind, Link); - - -- The tool that is going to be called - - Tool : Tool_Type := None; - - -- For each tool, Tool_Package_Names contains the name of the - -- corresponding package in the project file. - - Tool_Package_Names : constant array (Tool_Type) of Name_Id := - (None => No_Name, - List => Name_Gnatls, - Xref => Name_Cross_Reference, - Find => Name_Finder, - Stub => Name_Gnatstub, - Comp => No_Name, - Make => No_Name, - Bind => No_Name, - Link => No_Name); - - -- For each tool, Tool_Names contains the name of the executable - -- to be spawned. - - Gnatmake : constant String_Access := new String'("gnatmake"); - - Tool_Names : constant array (Tool_Type) of String_Access := - (None => null, - List => new String'("gnatls"), - Xref => new String'("gnatxref"), - Find => new String'("gnatfind"), - Stub => new String'("gnatstub"), - Comp => Gnatmake, - Make => Gnatmake, - Bind => Gnatmake, - Link => Gnatmake); - - Project_File : String_Access; - Project : Prj.Project_Id; - Current_Verbosity : Prj.Verbosity := Prj.Default; - - -- This flag indicates a switch -p (for gnatxref and gnatfind) for - -- an old fashioned project file. -p cannot be used in conjonction - -- with -P. - - Old_Project_File_Used : Boolean := False; - - Next_Arg : Positive; - - -- A table to keep the switches on the command line - - package Saved_Switches is new Table.Table ( - Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Gnatmain.Saved_Switches"); - - -- A table to keep the switches from the project file - - package Switches is new Table.Table ( - Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Gnatmain.Switches"); - - procedure Add_Switch (Argv : String; And_Save : Boolean); - -- Add a switch in one of the tables above - - procedure Display (Program : String; Args : Argument_List); - -- Displays Program followed by the arguments in Args - - function Index (Char : Character; Str : String) return Natural; - -- Returns the first occurrence of Char in Str. - -- Returns 0 if Char is not in Str. - - procedure Scan_Arg (Argv : String; And_Save : Boolean); - -- Scan and process arguments. Argv is a single argument. - - procedure Usage; - -- Output usage - - ---------------- - -- Add_Switch -- - ---------------- - - procedure Add_Switch (Argv : String; And_Save : Boolean) is - begin - if And_Save then - Saved_Switches.Increment_Last; - Saved_Switches.Table (Saved_Switches.Last) := new String'(Argv); - - else - Switches.Increment_Last; - Switches.Table (Switches.Last) := new String'(Argv); - end if; - end Add_Switch; - - ------------- - -- Display -- - ------------- - - procedure Display (Program : String; Args : Argument_List) is - begin - if not Opt.Quiet_Output then - Write_Str (Program); - - for J in Args'Range loop - Write_Str (" "); - Write_Str (Args (J).all); - end loop; - - Write_Eol; - end if; - end Display; - - ----------- - -- Index -- - ----------- - - function Index (Char : Character; Str : String) return Natural is - begin - for Index in Str'Range loop - if Str (Index) = Char then - return Index; - end if; - end loop; - - return 0; - end Index; - - -------------- - -- Scan_Arg -- - -------------- - - procedure Scan_Arg (Argv : String; And_Save : Boolean) is - begin - pragma Assert (Argv'First = 1); - - if Argv'Length = 0 then - return; - end if; - - if Argv (1) = Switch_Character or else Argv (1) = '-' then - - if Argv'Length = 1 then - Fail ("switch character cannot be followed by a blank"); - end if; - - -- The two style project files (-p and -P) cannot be used together - - if (Tool = Find or else Tool = Xref) - and then Argv (2) = 'p' - then - Old_Project_File_Used := True; - if Project_File /= null then - Fail ("-P and -p cannot be used together"); - end if; - end if; - - -- -q Be quiet: do not output tool command - - if Argv (2 .. Argv'Last) = "q" then - Opt.Quiet_Output := True; - - -- Only gnatstub and gnatmake have a -q switch - - if Tool = Stub or else Tool_Names (Tool) = Gnatmake then - Add_Switch (Argv, And_Save); - end if; - - -- gnatmake will take care of the project file related switches - - elsif Tool_Names (Tool) = Gnatmake then - Add_Switch (Argv, And_Save); - - -- -vPx Specify verbosity while parsing project files - - elsif Argv'Length = 4 and then Argv (2 .. 3) = "vP" then - case Argv (4) is - when '0' => - Current_Verbosity := Prj.Default; - when '1' => - Current_Verbosity := Prj.Medium; - when '2' => - Current_Verbosity := Prj.High; - when others => - null; - end case; - - -- -Pproject_file Specify project file to be used - - elsif Argv'Length >= 3 and then Argv (2) = 'P' then - - -- Only one -P switch can be used - - if Project_File /= null then - Fail (Argv & ": second project file forbidden (first is """ & - Project_File.all & """)"); - - -- The two style project files (-p and -P) cannot be used together - - elsif Old_Project_File_Used then - Fail ("-p and -P cannot be used together"); - - else - Project_File := new String'(Argv (3 .. Argv'Last)); - end if; - - -- -Xexternal=value Specify an external reference to be used - -- in project files - - elsif Argv'Length >= 5 and then Argv (2) = 'X' then - declare - Equal_Pos : constant Natural := - Index ('=', Argv (3 .. Argv'Last)); - begin - if Equal_Pos >= 4 and then - Equal_Pos /= Argv'Last then - Add (External_Name => Argv (3 .. Equal_Pos - 1), - Value => Argv (Equal_Pos + 1 .. Argv'Last)); - else - Fail (Argv & " is not a valid external assignment."); - end if; - end; - - else - Add_Switch (Argv, And_Save); - end if; - - else - Add_Switch (Argv, And_Save); - end if; - - end Scan_Arg; - - ----------- - -- Usage -- - ----------- - - procedure Usage is - begin - Write_Str ("Usage: "); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" list switches [list of object files]"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" xref switches file1 file2 ..."); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" find switches pattern[:sourcefile[:line[:column]]] " & - "[file1 file2 ...]"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" stub switches filename [directory]"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" comp switches files"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" make switches [files]"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" bind switches files"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" link switches files"); - Write_Eol; - - Write_Eol; - - Write_Str ("switches interpreted by "); - Osint.Write_Program_Name; - Write_Str (" for List Xref and Find:"); - Write_Eol; - - Write_Str (" -q Be quiet: do not output tool command"); - Write_Eol; - - Write_Str (" -Pproj Use GNAT Project File proj"); - Write_Eol; - - Write_Str (" -vPx Specify verbosity when parsing " & - "GNAT Project Files"); - Write_Eol; - - Write_Str (" -Xnm=val Specify an external reference for " & - "GNAT Project Files"); - Write_Eol; - - Write_Eol; - - Write_Str ("all other arguments are transmited to the tool"); - Write_Eol; - - Write_Eol; - - end Usage; - - begin - - Osint.Initialize (Unspecified); - - Namet.Initialize; - Csets.Initialize; - - Snames.Initialize; - - Prj.Initialize; - - if Arg_Count = 1 then - Usage; - return; - end if; - - -- Get the name of the tool - - declare - Tool_Name : String (1 .. Len_Arg (1)); - - begin - Fill_Arg (Tool_Name'Address, 1); - GNAT.Case_Util.To_Lower (Tool_Name); - - if Tool_Name = "list" then - Tool := List; - - elsif Tool_Name = "xref" then - Tool := Xref; - - elsif Tool_Name = "find" then - Tool := Find; - - elsif Tool_Name = "stub" then - Tool := Stub; - - elsif Tool_Name = "comp" then - Tool := Comp; - - elsif Tool_Name = "make" then - Tool := Make; - - elsif Tool_Name = "bind" then - Tool := Bind; - - elsif Tool_Name = "link" then - Tool := Link; - - else - Fail ("first argument needs to be ""list"", ""xref"", ""find""" & - ", ""stub"", ""comp"", ""make"", ""bind"" or ""link"""); - end if; - end; - - Next_Arg := 2; - - -- Get the command line switches that follow the name of the tool - - Scan_Args : while Next_Arg < Arg_Count loop - declare - Next_Argv : String (1 .. Len_Arg (Next_Arg)); - - begin - Fill_Arg (Next_Argv'Address, Next_Arg); - Scan_Arg (Next_Argv, And_Save => True); - end; - - Next_Arg := Next_Arg + 1; - end loop Scan_Args; - - -- If a switch -P was specified, parse the project file. - -- Project_File is always null if we are going to invoke gnatmake, - -- that is when Tool is Comp, Make, Bind or Link. - - if Project_File /= null then - - Prj.Pars.Set_Verbosity (To => Current_Verbosity); - - Prj.Pars.Parse - (Project => Project, - Project_File_Name => Project_File.all); - - if Project = Prj.No_Project then - Fail ("""" & Project_File.all & """ processing failed"); - end if; - - -- Check if a package with the name of the tool is in the project file - -- and if there is one, get the switches, if any, and scan them. - - declare - Data : Prj.Project_Data := Prj.Projects.Table (Project); - Pkg : Prj.Package_Id := - Prj.Util.Value_Of - (Name => Tool_Package_Names (Tool), - In_Packages => Data.Decl.Packages); - Element : Package_Element; - Default_Switches_Array : Array_Element_Id; - Switches : Prj.Variable_Value; - Current : Prj.String_List_Id; - The_String : String_Element; - - begin - if Pkg /= No_Package then - Element := Packages.Table (Pkg); - - -- Packages Gnatls and Gnatstub have a single attribute Switches, - -- that is not an associative array. - - if Tool = List or else Tool = Stub then - Switches := - Prj.Util.Value_Of - (Variable_Name => Name_Switches, - In_Variables => Element.Decl.Attributes); - - -- Packages Cross_Reference (for gnatxref) and Finder - -- (for gnatfind) have an attributed Default_Switches, - -- an associative array, indexed by the name of the - -- programming language. - else - Default_Switches_Array := - Prj.Util.Value_Of - (Name => Name_Default_Switches, - In_Arrays => Packages.Table (Pkg).Decl.Arrays); - Switches := Prj.Util.Value_Of - (Index => Name_Ada, - In_Array => Default_Switches_Array); - - end if; - - -- If there are switches specified in the package of the - -- project file corresponding to the tool, scan them. - - case Switches.Kind is - when Prj.Undefined => - null; - - when Prj.Single => - if String_Length (Switches.Value) > 0 then - String_To_Name_Buffer (Switches.Value); - Scan_Arg - (Name_Buffer (1 .. Name_Len), - And_Save => False); - end if; - - when Prj.List => - Current := Switches.Values; - while Current /= Prj.Nil_String loop - The_String := String_Elements.Table (Current); - - if String_Length (The_String.Value) > 0 then - String_To_Name_Buffer (The_String.Value); - Scan_Arg - (Name_Buffer (1 .. Name_Len), - And_Save => False); - end if; - - Current := The_String.Next; - end loop; - end case; - end if; - end; - - -- Set up the environment variables ADA_INCLUDE_PATH and - -- ADA_OBJECTS_PATH. - - Setenv - (Name => Ada_Include_Path, - Value => Prj.Env.Ada_Include_Path (Project).all); - Setenv - (Name => Ada_Objects_Path, - Value => Prj.Env.Ada_Objects_Path - (Project, Including_Libraries => False).all); - - end if; - - -- Gather all the arguments, those from the project file first, - -- locate the tool and call it with the arguments. - - declare - Args : Argument_List (1 .. Switches.Last + Saved_Switches.Last + 4); - Arg_Num : Natural := 0; - Tool_Path : String_Access; - Success : Boolean; - - procedure Add (Arg : String_Access); - - procedure Add (Arg : String_Access) is - begin - Arg_Num := Arg_Num + 1; - Args (Arg_Num) := Arg; - end Add; - - begin - - case Tool is - when Comp => - Add (new String'("-u")); - Add (new String'("-f")); - - when Bind => - Add (new String'("-b")); - - when Link => - Add (new String'("-l")); - - when others => - null; - - end case; - - for Index in 1 .. Switches.Last loop - Arg_Num := Arg_Num + 1; - Args (Arg_Num) := Switches.Table (Index); - end loop; - - for Index in 1 .. Saved_Switches.Last loop - Arg_Num := Arg_Num + 1; - Args (Arg_Num) := Saved_Switches.Table (Index); - end loop; - - Tool_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Tool_Names (Tool).all); - - if Tool_Path = null then - Fail ("error, unable to locate " & Tool_Names (Tool).all); - end if; - - Display (Tool_Names (Tool).all, Args (1 .. Arg_Num)); - - GNAT.OS_Lib.Spawn (Tool_Path.all, Args (1 .. Arg_Num), Success); - - end; - - end Gnatmain; --- 0 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatmain.ads gcc-3.3/gcc/ada/gnatmain.ads *** gcc-3.2.3/gcc/ada/gnatmain.ads 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatmain.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,38 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- G N A T M A I N -- - -- -- - -- S p e c -- - -- -- - -- $Revision: 1.1.14.1 $ - -- -- - -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- - -- -- - -- GNAT is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This procedure is the project-aware driver for the GNAT tools. - -- For gnatls, gnatxref, gnatfind and gnatstub, it setup the environment - -- variables ADA_INCLUDE_PATH and ADA_OBJECT_PATH and gather the switches - -- and file names from the project file (if any) and from the common line, - -- then call the non project-aware tool (gnatls, gnatxref, gnatfind or - -- gnatstub). - -- For other tools (compiler, binder, linker, gnatmake), it invokes - -- gnatmake with the proper switches. - - procedure Gnatmain; --- 0 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatmake.adb gcc-3.3/gcc/ada/gnatmake.adb *** gcc-3.2.3/gcc/ada/gnatmake.adb 2002-05-07 08:22:18.000000000 +0000 --- gcc-3.3/gcc/ada/gnatmake.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** *** 28,39 **** -- Gnatmake usage: please consult the gnat documentation - with Gnatvsn; with Make; procedure Gnatmake is - pragma Ident (Gnatvsn.Gnat_Version_String); - begin -- The real work is done in Package Make. Gnatmake used to be a standalone -- routine. Now Gnatmake's facilities have been placed in a package --- 27,35 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatmake.ads gcc-3.3/gcc/ada/gnatmake.ads *** gcc-3.2.3/gcc/ada/gnatmake.ads 2002-05-07 08:22:18.000000000 +0000 --- gcc-3.3/gcc/ada/gnatmake.ads 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatmem.adb gcc-3.3/gcc/ada/gnatmem.adb *** gcc-3.2.3/gcc/ada/gnatmem.adb 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatmem.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.3.10.1 $ -- -- ! -- Copyright (C) 1997-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,13 ---- -- -- -- B o d y -- -- -- -- -- ! -- Copyright (C) 1997-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- -- *************** procedure Gnatmem is *** 328,335 **** Put_Line (FD, " silent"); Put_Line (FD, " set lang c"); Put_Line (FD, " set print address on"); ! Put_Line (FD, " finish"); ! Put_Line (FD, " set $gm_addr = $"); Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""ALLOC^0x%x^\n"", $gm_addr"); Put_Line (FD, " set print address off"); --- 327,334 ---- Put_Line (FD, " silent"); Put_Line (FD, " set lang c"); Put_Line (FD, " set print address on"); ! Put_Line (FD, " up"); ! Put_Line (FD, " set $gm_addr = $pc"); Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""ALLOC^0x%x^\n"", $gm_addr"); Put_Line (FD, " set print address off"); *************** procedure Gnatmem is *** 341,348 **** Put_Line (FD, " set lang c"); Put_Line (FD, " set $gm_size = size"); Put_Line (FD, " set print address on"); ! Put_Line (FD, " finish"); ! Put_Line (FD, " set $gm_addr = $"); Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr"); Put_Line (FD, " set print address off"); --- 340,347 ---- Put_Line (FD, " set lang c"); Put_Line (FD, " set $gm_size = size"); Put_Line (FD, " set print address on"); ! Put_Line (FD, " up"); ! Put_Line (FD, " set $gm_addr = $pc"); Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr"); Put_Line (FD, " set print address off"); *************** procedure Gnatmem is *** 352,358 **** Put (FD, " backtrace"); if BT_Depth /= 0 then ! Put (FD, Integer'Image (BT_Depth)); end if; New_Line (FD); --- 351,357 ---- Put (FD, " backtrace"); if BT_Depth /= 0 then ! Put (FD, Integer'Image (BT_Depth + 1)); end if; New_Line (FD); *************** procedure Gnatmem is *** 369,380 **** Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""DEALL^0x%x^\n"", ptr"); Put_Line (FD, " set print address off"); ! Put_Line (FD, " finish"); Put (FD, " backtrace"); if BT_Depth /= 0 then ! Put (FD, Integer'Image (BT_Depth)); end if; New_Line (FD); --- 368,379 ---- Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""DEALL^0x%x^\n"", ptr"); Put_Line (FD, " set print address off"); ! Put_Line (FD, " up"); Put (FD, " backtrace"); if BT_Depth /= 0 then ! Put (FD, Integer'Image (BT_Depth + 1)); end if; New_Line (FD); *************** procedure Gnatmem is *** 434,440 **** New_Line; Put ("GNATMEM "); Put (Gnat_Version_String); ! Put_Line (" Copyright 1997-2000 Free Software Foundation, Inc."); New_Line; if Cross_Case then --- 433,439 ---- New_Line; Put ("GNATMEM "); Put (Gnat_Version_String); ! Put_Line (" Copyright 1997-2002 Free Software Foundation, Inc."); New_Line; if Cross_Case then diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatname.adb gcc-3.3/gcc/ada/gnatname.adb *** gcc-3.2.3/gcc/ada/gnatname.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/gnatname.adb 2002-10-23 08:04:17.000000000 +0000 *************** *** 0 **** --- 1,336 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T N A M E -- + -- -- + -- B o d y -- + -- -- + -- -- + -- 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- -- + -- 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. -- + -- -- + ------------------------------------------------------------------------------ + + with Gnatvsn; + with Opt; + with Osint; use Osint; + with Output; use Output; + with Prj.Makr; + with Table; + + with Ada.Text_IO; use Ada.Text_IO; + with GNAT.Command_Line; use GNAT.Command_Line; + with GNAT.OS_Lib; use GNAT.OS_Lib; + + procedure Gnatname is + + Usage_Output : Boolean := False; + -- Set to True when usage is output, to avoid multiple output + + Usage_Needed : Boolean := False; + -- Set to True by -h switch + + Version_Output : Boolean := False; + -- Set to True when version is output, to avoid multiple output + + Very_Verbose : Boolean := False; + -- Set to True with -v -v + + Create_Project : Boolean := False; + -- Set to True with a -P switch + + File_Path : String_Access := new String'("gnat.adc"); + -- Path name of the file specified by -c or -P switch + + File_Set : Boolean := False; + -- Set to True by -c or -P switch. + -- Used to detect multiple -c/-P switches. + + package Excluded_Patterns is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Gnatname.Excluded_Patterns"); + -- Table to accumulate the negative patterns. + + package Patterns is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Gnatname.Patterns"); + -- Table to accumulate the name patterns. + + package Source_Directories is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Gnatname.Source_Directories"); + -- Table to accumulate the source directories specified directly with -d + -- or indirectly with -D. + + procedure Output_Version; + -- Print name and version + + procedure Usage; + -- Print usage + + procedure Scan_Args; + -- Scan the command line arguments + + procedure Add_Source_Directory (S : String); + -- Add S in the Source_Directories table + + procedure Get_Directories (From_File : String); + -- Read a source directory text file + + -------------------------- + -- Add_Source_Directory -- + -------------------------- + + procedure Add_Source_Directory (S : String) is + begin + Source_Directories.Increment_Last; + Source_Directories.Table (Source_Directories.Last) := new String'(S); + end Add_Source_Directory; + + --------------------- + -- Get_Directories -- + --------------------- + + procedure Get_Directories (From_File : String) is + File : Ada.Text_IO.File_Type; + Line : String (1 .. 2_000); + Last : Natural; + + begin + Open (File, In_File, From_File); + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + if Last /= 0 then + Add_Source_Directory (Line (1 .. Last)); + end if; + end loop; + + Close (File); + + exception + when Name_Error => + Fail ("cannot open source directory """ & From_File & '"'); + end Get_Directories; + + -------------------- + -- Output_Version -- + -------------------- + + procedure Output_Version is + begin + if not Version_Output then + Version_Output := True; + Output.Write_Eol; + Output.Write_Str ("GNATNAME "); + Output.Write_Str (Gnatvsn.Gnat_Version_String); + Output.Write_Line + (" Copyright 2001-2002 Free Software Foundation, Inc."); + end if; + end Output_Version; + + --------------- + -- Scan_Args -- + --------------- + + procedure Scan_Args is + begin + Initialize_Option_Scan; + + -- Scan options first + + loop + case Getopt ("c: d: D: h P: v x:") is + when ASCII.NUL => + exit; + + when 'c' => + if File_Set then + Fail ("only one -P or -c switch may be specified"); + end if; + + File_Set := True; + File_Path := new String'(Parameter); + Create_Project := False; + + when 'd' => + Add_Source_Directory (Parameter); + + when 'D' => + Get_Directories (Parameter); + + when 'h' => + Usage_Needed := True; + + when 'P' => + if File_Set then + Fail ("only one -c or -P switch may be specified"); + end if; + + File_Set := True; + File_Path := new String'(Parameter); + Create_Project := True; + + when 'v' => + if Opt.Verbose_Mode then + Very_Verbose := True; + + else + Opt.Verbose_Mode := True; + end if; + + when 'x' => + Excluded_Patterns.Increment_Last; + Excluded_Patterns.Table (Excluded_Patterns.Last) := + new String'(Parameter); + + when others => + null; + end case; + end loop; + + -- Now, get the name patterns, if any + + loop + declare + S : constant String := Get_Argument (Do_Expansion => False); + + begin + exit when S = ""; + Patterns.Increment_Last; + Patterns.Table (Patterns.Last) := new String'(S); + end; + end loop; + + exception + when Invalid_Switch => + Fail ("invalid switch " & Full_Switch); + + end Scan_Args; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + if not Usage_Output then + Usage_Needed := False; + Usage_Output := True; + Write_Str ("Usage: "); + Osint.Write_Program_Name; + Write_Line (" [switches] naming-pattern [naming-patterns]"); + Write_Eol; + Write_Line ("switches:"); + + Write_Line (" -cfile create configuration pragmas file"); + Write_Line (" -ddir use dir as one of the source directories"); + Write_Line (" -Dfile get source directories from file"); + Write_Line (" -h output this help message"); + Write_Line (" -Pproj update or create project file proj"); + Write_Line (" -v verbose output"); + Write_Line (" -v -v very verbose output"); + Write_Line (" -xpat exclude pattern pat"); + end if; + end Usage; + + -- Start of processing for Gnatname + + begin + -- Initialize tables + + Excluded_Patterns.Set_Last (0); + Patterns.Set_Last (0); + Source_Directories.Set_Last (0); + + -- Get the arguments + + Scan_Args; + + if Opt.Verbose_Mode then + Output_Version; + end if; + + if Usage_Needed then + Usage; + end if; + + -- If no pattern was specified, print the usage and return + + if Patterns.Last = 0 then + Usage; + return; + end if; + + -- If no source directory was specified, use the current directory as the + -- unique directory. Note that if a file was specified with directory + -- information, the current directory is the directory of the specified + -- file. + + if Source_Directories.Last = 0 then + Source_Directories.Increment_Last; + Source_Directories.Table (Source_Directories.Last) := new String'("."); + end if; + + declare + Directories : Argument_List (1 .. Integer (Source_Directories.Last)); + Name_Patterns : Argument_List (1 .. Integer (Patterns.Last)); + Excl_Patterns : Argument_List (1 .. Integer (Excluded_Patterns.Last)); + + begin + -- Build the Directories and Name_Patterns arguments + + for Index in Directories'Range loop + Directories (Index) := Source_Directories.Table (Index); + end loop; + + for Index in Name_Patterns'Range loop + Name_Patterns (Index) := Patterns.Table (Index); + end loop; + + for Index in Excl_Patterns'Range loop + Excl_Patterns (Index) := Excluded_Patterns.Table (Index); + end loop; + + -- Call Prj.Makr.Make where the real work is done + + Prj.Makr.Make + (File_Path => File_Path.all, + Project_File => Create_Project, + Directories => Directories, + Name_Patterns => Name_Patterns, + Excluded_Patterns => Excl_Patterns, + Very_Verbose => Very_Verbose); + end; + + if Opt.Verbose_Mode then + Write_Eol; + end if; + end Gnatname; diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatname.ads gcc-3.3/gcc/ada/gnatname.ads *** gcc-3.2.3/gcc/ada/gnatname.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/gnatname.ads 2002-10-23 08:04:17.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T N A M E -- + -- -- + -- S p e c -- + -- -- + -- -- + -- Copyright (C) 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Tool for dealing with source files with arbitrary naming conventions. + -- It either creates a configuration pragmas file, or updates or creates + -- a project file. + + procedure Gnatname; diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatprep.adb gcc-3.3/gcc/ada/gnatprep.adb *** gcc-3.2.3/gcc/ada/gnatprep.adb 2002-05-04 03:28:12.000000000 +0000 --- gcc-3.3/gcc/ada/gnatprep.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,14 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- ! -- 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,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- -- *************** with GNAT.Command_Line; *** 37,45 **** with Gnatvsn; procedure GNATprep is - pragma Ident (Gnatvsn.Gnat_Version_String); - - Version_String : constant String := "$Revision: 1.1.16.1 $"; type Strptr is access String; --- 36,41 ---- *************** procedure GNATprep is *** 58,69 **** -- Argument Line Data -- ------------------------ - Infile_Name : Strptr; Outfile_Name : Strptr; Deffile_Name : Strptr; -- Names of files ! Infile : File_Type; Outfile : File_Type; Deffile : File_Type; --- 54,76 ---- -- Argument Line Data -- ------------------------ Outfile_Name : Strptr; Deffile_Name : Strptr; -- Names of files ! type Input; ! type Input_Ptr is access Input; ! type Input is record ! File : File_Type; ! Next : Input_Ptr; ! Prev : Input_Ptr; ! Name : Strptr; ! Line_Num : Natural := 0; ! end record; ! -- Data for the current input file (main input file or included file ! -- or definition file). ! ! Infile : Input_Ptr := new Input; Outfile : File_Type; Deffile : File_Type; *************** procedure GNATprep is *** 100,114 **** Line_Length : Natural; -- Length of line in Line_Buffer - Line_Num : Natural; - -- Current input file line number - Ptr : Natural; -- Input scan pointer for line in Line_Buffer type Keyword is (K_Not, K_Then, K_If, K_Else, K_End, K_Elsif, K_And, K_Or, K_Open_Paren, K_Close_Paren, ! K_Defined, K_Andthen, K_Orelse, K_Equal, K_None); -- Keywords that are recognized on preprocessor lines. K_None indicates -- that no keyword was present. --- 107,119 ---- Line_Length : Natural; -- Length of line in Line_Buffer Ptr : Natural; -- Input scan pointer for line in Line_Buffer type Keyword is (K_Not, K_Then, K_If, K_Else, K_End, K_Elsif, K_And, K_Or, K_Open_Paren, K_Close_Paren, ! K_Defined, K_Andthen, K_Orelse, K_Equal, K_Include, ! K_None); -- Keywords that are recognized on preprocessor lines. K_None indicates -- that no keyword was present. *************** procedure GNATprep is *** 131,136 **** --- 136,144 ---- If_Line : Positive; -- Line number for #if line + If_Name : Strptr; + -- File name of #if line + Else_Line : Natural; -- Line number for #else line, zero = no else seen yet *************** procedure GNATprep is *** 141,146 **** --- 149,155 ---- -- True if either the #if condition or one of the previously seen -- #elsif lines was true, meaning that any future #elsif sections -- or the #else section, is to be deleted. + end record; PP_Depth : Natural; *************** procedure GNATprep is *** 162,168 **** procedure Error (Msg : String); -- Post error message with given text. The line number is taken from ! -- Line_Num, and the column number from Ptr. function Eval_Condition (Parenthesis : Natural := 0; --- 171,177 ---- procedure Error (Msg : String); -- Post error message with given text. The line number is taken from ! -- Infile.Line_Num, and the column number from Ptr. function Eval_Condition (Parenthesis : Natural := 0; *************** procedure GNATprep is *** 184,189 **** --- 193,201 ---- procedure Help_Page; -- Print a help page to summarize the usage of gnatprep + function Image (N : Natural) return String; + -- Returns Natural'Image (N) without the initial space + function Is_Preprocessor_Line return Boolean; -- Tests if current line is a preprocessor line, i.e. that its first -- non-blank character is a # character. If so, then a result of True *************** procedure GNATprep is *** 244,250 **** ----------- procedure Error (Msg : String) is ! L : constant String := Natural'Image (Line_Num); C : constant String := Natural'Image (Ptr); begin --- 256,262 ---- ----------- procedure Error (Msg : String) is ! L : constant String := Natural'Image (Infile.Line_Num); C : constant String := Natural'Image (Ptr); begin *************** procedure GNATprep is *** 419,424 **** --- 431,437 ---- when K_Equal => -- Read the second part of the statement + Skip_Spaces; Start_Sym := Ptr; *************** procedure GNATprep is *** 510,518 **** procedure Help_Page is begin Put_Line (Standard_Error, ! "GNAT Preprocessor Version " & ! Version_String (12 .. 15) & ! " Copyright 1996-2001 Free Software Foundation, Inc."); Put_Line (Standard_Error, "Usage: gnatprep [-bcrsu] [-Dsymbol=value] infile " & "outfile [deffile]"); --- 523,531 ---- procedure Help_Page is begin Put_Line (Standard_Error, ! "GNAT Preprocessor " & ! Gnatvsn.Gnat_Version_String & ! " Copyright 1996-2002 Free Software Foundation, Inc."); Put_Line (Standard_Error, "Usage: gnatprep [-bcrsu] [-Dsymbol=value] infile " & "outfile [deffile]"); *************** procedure GNATprep is *** 533,538 **** --- 546,561 ---- New_Line (Standard_Error); end Help_Page; + ----------- + -- Image -- + ----------- + + function Image (N : Natural) return String is + Result : constant String := Natural'Image (N); + begin + return Result (Result'First + 1 .. Result'Last); + end Image; + -------------------------- -- Is_Preprocessor_Line -- -------------------------- *************** procedure GNATprep is *** 654,667 **** begin Open (Deffile, In_File, Deffile_Name.all); ! Line_Num := 0; Current_File_Name := Deffile_Name; -- Loop through lines in symbol definitions file while not End_Of_File (Deffile) loop Get_Line (Deffile, Line_Buffer, Line_Length); ! Line_Num := Line_Num + 1; Ptr := 1; Skip_Spaces; --- 677,692 ---- begin Open (Deffile, In_File, Deffile_Name.all); ! -- Initialize data for procedure Error ! ! Infile.Line_Num := 0; Current_File_Name := Deffile_Name; -- Loop through lines in symbol definitions file while not End_Of_File (Deffile) loop Get_Line (Deffile, Line_Buffer, Line_Length); ! Infile.Line_Num := Infile.Line_Num + 1; Ptr := 1; Skip_Spaces; *************** procedure GNATprep is *** 826,831 **** --- 851,859 ---- elsif Matching_Strings (Sym, "'defined") then return K_Defined; + elsif Matching_Strings (Sym, "include") then + return K_Include; + elsif Sym = "(" then return K_Open_Paren; *************** begin *** 991,998 **** begin exit when S'Length = 0; ! if Infile_Name = null then ! Infile_Name := new String'(S); elsif Outfile_Name = null then Outfile_Name := new String'(S); elsif Deffile_Name = null then --- 1019,1026 ---- begin exit when S'Length = 0; ! if Infile.Name = null then ! Infile.Name := new String'(S); elsif Outfile_Name = null then Outfile_Name := new String'(S); elsif Deffile_Name = null then *************** begin *** 1005,1011 **** -- Test we had all the arguments needed ! if Infile_Name = null or else Outfile_Name = null then raise Usage_Error; --- 1033,1039 ---- -- Test we had all the arguments needed ! if Infile.Name = null or else Outfile_Name = null then raise Usage_Error; *************** begin *** 1111,1121 **** -- Open files and initialize preprocessing begin ! Open (Infile, In_File, Infile_Name.all); exception when Name_Error => ! Put_Line (Standard_Error, "cannot open " & Infile_Name.all); raise Fatal_Error; end; --- 1139,1149 ---- -- Open files and initialize preprocessing begin ! Open (Infile.File, In_File, Infile.Name.all); exception when Name_Error => ! Put_Line (Standard_Error, "cannot open " & Infile.Name.all); raise Fatal_Error; end; *************** begin *** 1128,1149 **** raise Fatal_Error; end; ! if Source_Ref_Pragma then ! Put_Line ! (Outfile, "pragma Source_Reference (1, """ & Infile_Name.all & """);"); ! end if; ! ! Line_Num := 0; ! Current_File_Name := Infile_Name; PP_Depth := 0; PP (0).Deleting := False; -- Loop through lines in input file ! while not End_Of_File (Infile) loop ! Get_Line (Infile, Line_Buffer, Line_Length); ! Line_Num := Line_Num + 1; -- Handle preprocessor line --- 1156,1189 ---- raise Fatal_Error; end; ! Infile.Line_Num := 0; ! Current_File_Name := Infile.Name; PP_Depth := 0; PP (0).Deleting := False; + -- We return here after we start reading an include file and after + -- we have finished reading an include file. + + <> + + -- If we generate Source_Reference pragmas, then generate one + -- either with line number 1 for a newly included file, or + -- with the number of the next line when we have returned to the + -- including file. + + if Source_Ref_Pragma then + Put_Line + (Outfile, "pragma Source_Reference (" & + Image (Infile.Line_Num + 1) & + ", """ & Infile.Name.all & """);"); + end if; + -- Loop through lines in input file ! while not End_Of_File (Infile.File) loop ! Get_Line (Infile.File, Line_Buffer, Line_Length); ! Infile.Line_Num := Infile.Line_Num + 1; -- Handle preprocessor line *************** begin *** 1152,1157 **** --- 1192,1303 ---- case K is + -- Include file + + when K_Include => + -- Ignore if Deleting is True + + if PP (PP_Depth).Deleting then + goto Output; + end if; + + Skip_Spaces; + + if Ptr >= Line_Length then + Error ("no file to include"); + + elsif Line_Buffer (Ptr) /= '"' then + Error + ("file to include must be specified as a literal string"); + + else + declare + Start_File : constant Positive := Ptr + 1; + + begin + Ptr := Line_Length; + + while Line_Buffer (Ptr) = ' ' + or else Line_Buffer (Ptr) = ASCII.HT + loop + Ptr := Ptr - 1; + end loop; + + if Ptr <= Start_File + or else Line_Buffer (Ptr) /= '"' + then + Error ("no string literal for included file"); + + else + if Infile.Next = null then + Infile.Next := new Input; + Infile.Next.Prev := Infile; + end if; + + Infile := Infile.Next; + Infile.Name := + new String'(Line_Buffer (Start_File .. Ptr - 1)); + + -- Check for circularity: an file including itself, + -- either directly or indirectly. + + declare + File : Input_Ptr := Infile.Prev; + + begin + while File /= null + and then File.Name.all /= Infile.Name.all + loop + File := File.Prev; + end loop; + + if File /= null then + Infile := Infile.Prev; + Error ("circularity in included files"); + + while File.Prev /= null loop + File := File.Prev; + end loop; + + while File /= Infile.Next loop + Error ('"' & File.Name.all & + """ includes """ & + File.Next.Name.all & '"'); + File := File.Next; + end loop; + + else + -- We have a file name and no circularity. + -- Open the file and record an error if the + -- file cannot be opened. + + begin + Open (Infile.File, In_File, Infile.Name.all); + Current_File_Name := Infile.Name; + Infile.Line_Num := 0; + + -- If we use Source_Reference pragma, + -- we need to output one for this new file. + goto Read_In_File; + + exception + when Name_Error => + + -- We need to set the input file to + -- the including file, so that the + -- line number is correct when reporting + -- the error. + + Infile := Infile.Prev; + Error ("cannot open """ & + Infile.Next.Name.all & '"'); + end; + end if; + end; + end if; + end; + end if; + -- If/Elsif processing when K_If | K_Elsif => *************** begin *** 1165,1171 **** if K = K_If then PP_Depth := PP_Depth + 1; PP (PP_Depth) := ! (If_Line => Line_Num, Else_Line => 0, Deleting => False, Match_Seen => PP (PP_Depth - 1).Deleting); --- 1311,1318 ---- if K = K_If then PP_Depth := PP_Depth + 1; PP (PP_Depth) := ! (If_Line => Infile.Line_Num, ! If_Name => Infile.Name, Else_Line => 0, Deleting => False, Match_Seen => PP (PP_Depth - 1).Deleting); *************** begin *** 1202,1208 **** ")"); else ! PP (PP_Depth).Else_Line := Line_Num; PP (PP_Depth).Deleting := PP (PP_Depth).Match_Seen; end if; --- 1349,1355 ---- ")"); else ! PP (PP_Depth).Else_Line := Infile.Line_Num; PP (PP_Depth).Deleting := PP (PP_Depth).Match_Seen; end if; *************** begin *** 1356,1364 **** end if; end loop; for J in 1 .. PP_Depth loop ! Error ("no matching #end for #if at line" & ! Natural'Image (PP (J).If_Line)); end loop; if Num_Errors = 0 then --- 1503,1527 ---- end if; end loop; + -- If we have finished reading an included file, close it and continue + -- with the next line of the including file. + + if Infile.Prev /= null then + Close (Infile.File); + Infile := Infile.Prev; + Current_File_Name := Infile.Name; + goto Read_In_File; + end if; + for J in 1 .. PP_Depth loop ! if PP (J).If_Name = Infile.Name then ! Error ("no matching #end for #if at line" & ! Natural'Image (PP (J).If_Line)); ! else ! Error ("no matching #end for #if at line" & ! Natural'Image (PP (J).If_Line) & ! " of file """ & PP (J).If_Name.all & '"'); ! end if; end loop; if Num_Errors = 0 then diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatprep.ads gcc-3.3/gcc/ada/gnatprep.ads *** gcc-3.2.3/gcc/ada/gnatprep.ads 2002-05-07 08:22:18.000000000 +0000 --- gcc-3.3/gcc/ada/gnatprep.ads 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- $Revision: 1.1.16.2 $ -- -- -- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatpsta.adb gcc-3.3/gcc/ada/gnatpsta.adb *** gcc-3.2.3/gcc/ada/gnatpsta.adb 2002-05-04 03:28:13.000000000 +0000 --- gcc-3.3/gcc/ada/gnatpsta.adb 2002-10-23 07:33:25.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- $Revision: 1.1.16.1 $ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- --- 6,11 ---- *************** *** 35,47 **** -- integer and floating point sizes. with Ada.Text_IO; use Ada.Text_IO; - with Gnatvsn; with Ttypef; use Ttypef; with Ttypes; use Ttypes; with Types; use Types; procedure GnatPsta is - pragma Ident (Gnatvsn.Gnat_Version_String); procedure P (Item : String) renames Ada.Text_IO.Put_Line; --- 34,44 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnatpsys.adb gcc-3.3/gcc/ada/gnatpsys.adb *** gcc-3.2.3/gcc/ada/gnatpsys.adb 2002-05-07 08:22:18.000000000 +0000 --- gcc-3.3/gcc/ada/gnatpsys.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,171 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT SYSTEM UTILITIES -- - -- -- - -- G N A T P S Y S -- - -- -- - -- B o d y -- - -- -- - -- $Revision: 1.1.16.2 $ - -- -- - -- 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- -- - -- 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. -- - -- -- - ------------------------------------------------------------------------------ - - -- Program to print out listing of System package with all constants - -- appearing explicitly. - - with Ada.Text_IO; - with System; use System; - with Gnatvsn; - - procedure GnatPsys is - pragma Ident (Gnatvsn.Gnat_Version_String); - - procedure P (Item : String) renames Ada.Text_IO.Put_Line; - - begin - P ("package System is"); - - P ("pragma Pure (System);"); - - P (""); - - P (" type Name is (SYSTEM_NAME_GNAT);"); - - P (" System_Name : constant Name := SYSTEM_NAME_GNAT;"); - - P (""); - - P (" -- System-Dependent Named Numbers"); - - P (""); - - P (" Min_Int : constant := -(2 **" & - Long_Long_Integer'Image (Long_Long_Integer'Size - 1) & ");"); - - P (" Max_Int : constant := 2 **" & - Long_Long_Integer'Image (Long_Long_Integer'Size - 1) & " - 1;"); - - P (""); - - P (" Max_Binary_Modulus : constant := 2 **" & - Long_Long_Integer'Image (Long_Long_Integer'Size) & ";"); - - P (" Max_Nonbinary_Modulus : constant :=" & - Integer'Image (Integer'Last) & ";"); - - P (""); - - P (" Max_Base_Digits : constant :=" & - Natural'Image (Long_Long_Float'Digits) & ";"); - - P (" Max_Digits : constant :=" & - Natural'Image (Long_Long_Float'Digits) & ";"); - - P (""); - - P (" Max_Mantissa : constant := 63;"); - - P (" Fine_Delta : constant := 2.0 ** (-Max_Mantissa);"); - - P (""); - - P (" Tick : constant :=" & - Duration'Image (Duration (Standard'Tick)) & ";"); - - P (""); - - P (" -- Storage-related Declarations"); - - P (""); - - P (" type Address is private;"); - - P (" Null_Address : constant Address;"); - - P (""); - - P (" Storage_Unit : constant :=" & - Natural'Image (Standard'Storage_Unit) & ";"); - - P (" Word_Size : constant :=" & - Natural'Image (Standard'Word_Size) & ";"); - - P (" Memory_Size : constant := 2 **" & - Natural'Image (Standard'Address_Size) & ";"); - - P (""); - P (" -- Address comparison"); - P (""); - P (" function ""<"" (Left, Right : Address) return Boolean;"); - P (" function ""<="" (Left, Right : Address) return Boolean;"); - P (" function "">"" (Left, Right : Address) return Boolean;"); - P (" function "">="" (Left, Right : Address) return Boolean;"); - P (" function ""="" (Left, Right : Address) return Boolean;"); - P (""); - P (" pragma Import (Intrinsic, ""<""); "); - P (" pragma Import (Intrinsic, ""<="");"); - P (" pragma Import (Intrinsic, "">""); "); - P (" pragma Import (Intrinsic, "">="");"); - P (" pragma Import (Intrinsic, ""=""); "); - P (""); - P (" -- Other System-Dependent Declarations"); - P (""); - P (" type Bit_Order is (High_Order_First, Low_Order_First);"); - P (" Default_Bit_Order : constant Bit_Order;"); - P (""); - P (" -- Priority-related Declarations (RM D.1)"); - P (""); - P (" subtype Any_Priority is Integer range 0 .." & - Natural'Image (Standard'Max_Interrupt_Priority) & ";"); - - P (""); - - P (" subtype Priority is Any_Priority range 0 .." & - Natural'Image (Standard'Max_Priority) & ";"); - - P (""); - - P (" subtype Interrupt_Priority is Any_Priority range" & - Natural'Image (Standard'Max_Priority + 1) & " .." & - Natural'Image (Standard'Max_Interrupt_Priority) & ";"); - - P (""); - - P (" Default_Priority : constant Priority :=" & - Natural'Image ((Priority'First + Priority'Last) / 2) & ";"); - - P (""); - - P ("private"); - - P (""); - - P (" type Address is mod Memory_Size; "); - - P (" Null_Address : constant Address := 0; "); - - P (" "); - - P (" Default_Bit_Order : constant Bit_Order := " & - Bit_Order'Image (Bit_Order'Val (Standard'Default_Bit_Order)) & ";"); - - P (""); - - P ("end System;"); - end GnatPsys; --- 0 ---- diff -Nrc3pad gcc-3.2.3/gcc/ada/gnat_rm.info gcc-3.3/gcc/ada/gnat_rm.info *** gcc-3.2.3/gcc/ada/gnat_rm.info 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.3/gcc/ada/gnat_rm.info 2003-05-14 00:31:47.000000000 +0000 *************** *** 0 **** --- 1,11455 ---- + This is ada/gnat_rm.info, produced by makeinfo version 4.2 from + ada/gnat_rm.texi. + + INFO-DIR-SECTION GNU Ada tools + START-INFO-DIR-ENTRY + * GNAT Reference Manual: (gnat_rm). Reference Manual for GNU Ada tools. + END-INFO-DIR-ENTRY + + Copyright (C) 1995-2001, Free Software Foundation + + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.2 or + any later version published by the Free Software Foundation; with the + Invariant Sections being "GNU Free Documentation License", with the + Front-Cover Texts being "GNAT Reference Manual", and with no Back-Cover + Texts. A copy of the license is included in the section entitled "GNU + Free Documentation License". +  + File: gnat_rm.info, Node: Top, Next: About This Guide, Prev: (dir), Up: (dir) + + GNAT Reference Manual + ********************* + + GNAT Reference Manual + + GNAT, The GNU Ada 95 Compiler + + GNAT Version for GCC 3.3 + + Ada Core Technologies, Inc. + + Copyright (C) 1995-2001, Free Software Foundation + + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.2 or + any later version published by the Free Software Foundation; with the + Invariant Sections being "GNU Free Documentation License", with the + Front-Cover Texts being "GNAT Reference Manual", and with no Back-Cover + Texts. A copy of the license is included in the section entitled "GNU + Free Documentation License". + * Menu: + + * About This Guide:: + * Implementation Defined Pragmas:: + * Implementation Defined Attributes:: + * Implementation Advice:: + * Implementation Defined Characteristics:: + * Intrinsic Subprograms:: + * Representation Clauses and Pragmas:: + * Standard Library Routines:: + * The Implementation of Standard I/O:: + * The GNAT Library:: + * Interfacing to Other Languages:: + * Machine Code Insertions:: + * GNAT Implementation of Tasking:: + * Code generation for array aggregates:: + * Specialized Needs Annexes:: + * Compatibility Guide:: + * GNU Free Documentation License:: + * Index:: + + --- The Detailed Node Listing --- + + About This Guide + + * What This Reference Manual Contains:: + * Related Information:: + + The Implementation of Standard I/O + + * Standard I/O Packages:: + * FORM Strings:: + * Direct_IO:: + * Sequential_IO:: + * Text_IO:: + * Wide_Text_IO:: + * Stream_IO:: + * Shared Files:: + * Open Modes:: + * Operations on C Streams:: + * Interfacing to C Streams:: + + The GNAT Library + + * Ada.Characters.Latin_9 (a-chlat9.ads):: + * Ada.Characters.Wide_Latin_1 (a-cwila1.ads):: + * Ada.Characters.Wide_Latin_9 (a-cwila9.ads):: + * Ada.Command_Line.Remove (a-colire.ads):: + * Ada.Direct_IO.C_Streams (a-diocst.ads):: + * Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads):: + * Ada.Sequential_IO.C_Streams (a-siocst.ads):: + * Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads):: + * Ada.Strings.Unbounded.Text_IO (a-suteio.ads):: + * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: + * Ada.Text_IO.C_Streams (a-tiocst.ads):: + * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: + * GNAT.AWK (g-awk.ads):: + * GNAT.Bubble_Sort_A (g-busora.ads):: + * GNAT.Bubble_Sort_G (g-busorg.ads):: + * GNAT.Calendar (g-calend.ads):: + * GNAT.Calendar.Time_IO (g-catiio.ads):: + * GNAT.Case_Util (g-casuti.ads):: + * GNAT.CGI (g-cgi.ads):: + * GNAT.CGI.Cookie (g-cgicoo.ads):: + * GNAT.CGI.Debug (g-cgideb.ads):: + * GNAT.Command_Line (g-comlin.ads):: + * GNAT.CRC32 (g-crc32.ads):: + * GNAT.Current_Exception (g-curexc.ads):: + * GNAT.Debug_Pools (g-debpoo.ads):: + * GNAT.Debug_Utilities (g-debuti.ads):: + * GNAT.Directory_Operations (g-dirope.ads):: + * GNAT.Dynamic_Tables (g-dyntab.ads):: + * GNAT.Exception_Traces (g-exctra.ads):: + * GNAT.Expect (g-expect.ads):: + * GNAT.Float_Control (g-flocon.ads):: + * GNAT.Heap_Sort_A (g-hesora.ads):: + * GNAT.Heap_Sort_G (g-hesorg.ads):: + * GNAT.HTable (g-htable.ads):: + * GNAT.IO (g-io.ads):: + * GNAT.IO_Aux (g-io_aux.ads):: + * GNAT.Lock_Files (g-locfil.ads):: + * GNAT.MD5 (g-md5.ads):: + * GNAT.Most_Recent_Exception (g-moreex.ads):: + * GNAT.OS_Lib (g-os_lib.ads):: + * GNAT.Regexp (g-regexp.ads):: + * GNAT.Registry (g-regist.ads):: + * GNAT.Regpat (g-regpat.ads):: + * GNAT.Sockets (g-socket.ads):: + * GNAT.Source_Info (g-souinf.ads):: + * GNAT.Spell_Checker (g-speche.ads):: + * GNAT.Spitbol.Patterns (g-spipat.ads):: + * GNAT.Spitbol (g-spitbo.ads):: + * GNAT.Spitbol.Table_Boolean (g-sptabo.ads):: + * GNAT.Spitbol.Table_Integer (g-sptain.ads):: + * GNAT.Spitbol.Table_VString (g-sptavs.ads):: + * GNAT.Table (g-table.ads):: + * GNAT.Task_Lock (g-tasloc.ads):: + * GNAT.Threads (g-thread.ads):: + * GNAT.Traceback (g-traceb.ads):: + * GNAT.Traceback.Symbolic (g-trasym.ads):: + * Interfaces.C.Extensions (i-cexten.ads):: + * Interfaces.C.Streams (i-cstrea.ads):: + * Interfaces.CPP (i-cpp.ads):: + * Interfaces.Os2lib (i-os2lib.ads):: + * Interfaces.Os2lib.Errors (i-os2err.ads):: + * Interfaces.Os2lib.Synchronization (i-os2syn.ads):: + * Interfaces.Os2lib.Threads (i-os2thr.ads):: + * Interfaces.Packed_Decimal (i-pacdec.ads):: + * Interfaces.VxWorks (i-vxwork.ads):: + * Interfaces.VxWorks.IO (i-vxwoio.ads):: + * System.Address_Image (s-addima.ads):: + * System.Assertions (s-assert.ads):: + * System.Partition_Interface (s-parint.ads):: + * System.Task_Info (s-tasinf.ads):: + * System.Wch_Cnv (s-wchcnv.ads):: + * System.Wch_Con (s-wchcon.ads):: + + Text_IO + + * Text_IO Stream Pointer Positioning:: + * Text_IO Reading and Writing Non-Regular Files:: + * Get_Immediate:: + * Treating Text_IO Files as Streams:: + * Text_IO Extensions:: + * Text_IO Facilities for Unbounded Strings:: + + Wide_Text_IO + + * Wide_Text_IO Stream Pointer Positioning:: + * Wide_Text_IO Reading and Writing Non-Regular Files:: + + Interfacing to Other Languages + + * Interfacing to C:: + * Interfacing to C++:: + * Interfacing to COBOL:: + * Interfacing to Fortran:: + * Interfacing to non-GNAT Ada code:: + + GNAT Implementation of Tasking + + * Mapping Ada Tasks onto the Underlying Kernel Threads:: + * Ensuring Compliance with the Real-Time Annex:: + +  + File: gnat_rm.info, Node: About This Guide, Next: Implementation Defined Pragmas, Prev: Top, Up: Top + + About This Guide + **************** + + This manual contains useful information in writing programs using the + GNAT compiler. It includes information on implementation dependent + characteristics of GNAT, including all the information required by Annex + M of the standard. + + Ada 95 is designed to be highly portable,and guarantees that, for + most programs, Ada 95 compilers behave in exactly the same manner on + different machines. However, since Ada 95 is designed to be used in a + wide variety of applications, it also contains a number of system + dependent features to Functbe used in interfacing to the external world. + + Note: Any program that makes use of implementation-dependent features + may be non-portable. You should follow good programming practice and + isolate and clearly document any sections of your program that make use + of these features in a non-portable manner. + + * Menu: + + * What This Reference Manual Contains:: + * Conventions:: + * Related Information:: + +  + File: gnat_rm.info, Node: What This Reference Manual Contains, Next: Conventions, Up: About This Guide + + What This Reference Manual Contains + =================================== + + This reference manual contains the following chapters: + + * *Note Implementation Defined Pragmas:: lists GNAT + implementation-dependent pragmas, which can be used to extend and + enhance the functionality of the compiler. + + * *Note Implementation Defined Attributes:: lists GNAT + implementation-dependent attributes which can be used to extend and + enhance the functionality of the compiler. + + * *Note Implementation Advice:: provides information on generally + desirable behavior which are not requirements that all compilers + must follow since it cannot be provided on all systems, or which + may be undesirable on some systems. + + * *Note Implementation Defined Characteristics:: provides a guide to + minimizing implementation dependent features. + + * *Note Intrinsic Subprograms:: describes the intrinsic subprograms + implemented by GNAT, and how they can be imported into user + application programs. + + * *Note Representation Clauses and Pragmas:: describes in detail the + way that GNAT represents data, and in particular the exact set of + representation clauses and pragmas that is accepted. + + * *Note Standard Library Routines:: provides a listing of packages + and a brief description of the functionality that is provided by + Ada's extensive set of standard library routines as implemented by + GNAT. + + * *Note The Implementation of Standard I/O:: details how the GNAT + implementation of the input-output facilities. + + * *Note Interfacing to Other Languages:: describes how programs + written in Ada using GNAT can be interfaced to other programming + languages. + + * *Note Specialized Needs Annexes:: describes the GNAT + implementation of all of the special needs annexes. + + * *Note Compatibility Guide:: includes sections on compatibility of + GNAT with other Ada 83 and Ada 95 compilation systems, to assist + in porting code from other environments. + + This reference manual assumes that you are familiar with Ada 95 + language, as described in the International Standard + ANSI/ISO/IEC-8652:1995, Jan 1995. + +  + File: gnat_rm.info, Node: Conventions, Next: Related Information, Prev: What This Reference Manual Contains, Up: About This Guide + + Conventions + =========== + + Following are examples of the typographical and graphic conventions used + in this guide: + + * `Functions', `utility program names', `standard names', and + `classes'. + + * `Option flags' + + * `File Names', `button names', and `field names'. + + * `Variables'. + + * _Emphasis_. + + * [optional information or parameters] + + * Examples are described by text + and then shown this way. + + Commands that are entered by the user are preceded in this manual by the + characters `$ ' (dollar sign followed by space). If your system uses + this sequence as a prompt, then the commands will appear exactly as you + see them in the manual. If your system uses some other prompt, then + the command will appear with the `$' replaced by whatever prompt + character you are using. + +  + File: gnat_rm.info, Node: Related Information, Prev: Conventions, Up: About This Guide + + Related Information + =================== + + See the following documents for further information on GNAT: + + * `GNAT User's Guide', which provides information on how to use the + GNAT compiler system. + + * `Ada 95 Reference Manual', which contains all reference material + for the Ada 95 programming language. + + * `Ada 95 Annotated Reference Manual', which is an annotated version + of the standard reference manual cited above. The annotations + describe detailed aspects of the design decision, and in + particular contain useful sections on Ada 83 compatibility. + + * `DEC Ada, Technical Overview and Comparison on DIGITAL Platforms', + which contains specific information on compatibility between GNAT + and DEC Ada 83 systems. + + * `DEC Ada, Language Reference Manual, part number AA-PYZAB-TK' which + describes in detail the pragmas and attributes provided by the DEC + Ada 83 compiler system. + + +  + File: gnat_rm.info, Node: Implementation Defined Pragmas, Next: Implementation Defined Attributes, Prev: About This Guide, Up: Top + + Implementation Defined Pragmas + ****************************** + + Ada 95 defines a set of pragmas that can be used to supply additional + information to the compiler. These language defined pragmas are + implemented in GNAT and work as described in the Ada 95 Reference + Manual. + + In addition, Ada 95 allows implementations to define additional + pragmas whose meaning is defined by the implementation. GNAT provides + a number of these implementation-dependent pragmas which can be used to + extend and enhance the functionality of the compiler. This section of + the GNAT Reference Manual describes these additional pragmas. + + Note that any program using these pragmas may not be portable to + other compilers (although GNAT implements this set of pragmas on all + platforms). Therefore if portability to other compilers is an important + consideration, the use of these pragmas should be minimized. + + `pragma Abort_Defer' + Syntax: + + pragma Abort_Defer; + + This pragma must appear at the start of the statement sequence of a + handled sequence of statements (right after the `begin'). It has + the effect of deferring aborts for the sequence of statements (but + not for the declarations or handlers, if any, associated with this + statement sequence). + + `pragma Ada_83' + Syntax: + + pragma Ada_83; + + A configuration pragma that establishes Ada 83 mode for the unit to + which it applies, regardless of the mode set by the command line + switches. In Ada 83 mode, GNAT attempts to be as compatible with + the syntax and semantics of Ada 83, as defined in the original Ada + 83 Reference Manual as possible. In particular, the new Ada 95 + keywords are not recognized, optional package bodies are allowed, + and generics may name types with unknown discriminants without + using the `(<>)' notation. In addition, some but not all of the + additional restrictions of Ada 83 are enforced. + + Ada 83 mode is intended for two purposes. Firstly, it allows + existing legacy Ada 83 code to be compiled and adapted to GNAT + with less effort. Secondly, it aids in keeping code backwards + compatible with Ada 83. However, there is no guarantee that code + that is processed correctly by GNAT in Ada 83 mode will in fact + compile and execute with an Ada 83 compiler, since GNAT does not + enforce all the additional checks required by Ada 83. + + `pragma Ada_95' + Syntax: + + pragma Ada_95; + + A configuration pragma that establishes Ada 95 mode for the unit + to which it applies, regardless of the mode set by the command + line switches. This mode is set automatically for the `Ada' and + `System' packages and their children, so you need not specify it + in these contexts. This pragma is useful when writing a reusable + component that itself uses Ada 95 features, but which is intended + to be usable from either Ada 83 or Ada 95 programs. + + `pragma Annotate' + Syntax: + + pragma Annotate (IDENTIFIER {, ARG}); + + ARG ::= NAME | EXPRESSION + + This pragma is used to annotate programs. IDENTIFIER identifies + the type of annotation. GNAT verifies this is an identifier, but + does not otherwise analyze it. The ARG argument can be either a + string literal or an expression. String literals are assumed to + be of type `Standard.String'. Names of entities are simply + analyzed as entity names. All other expressions are analyzed as + expressions, and must be unambiguous. + + The analyzed pragma is retained in the tree, but not otherwise + processed by any part of the GNAT compiler. This pragma is + intended for use by external tools, including ASIS. + + `pragma Assert' + Syntax: + + pragma Assert ( + boolean_EXPRESSION + [, static_string_EXPRESSION]) + + The effect of this pragma depends on whether the corresponding + command line switch is set to activate assertions. The pragma + expands into code equivalent to the following: + + if assertions-enabled then + if not boolean_EXPRESSION then + System.Assertions.Raise_Assert_Failure + (string_EXPRESSION); + end if; + end if; + + The string argument, if given, is the message that will be + associated with the exception occurrence if the exception is + raised. If no second argument is given, the default message is + `FILE:NNN', where FILE is the name of the source file containing + the assert, and NNN is the line number of the assert. A pragma is + not a statement, so if a statement sequence contains nothing but a + pragma assert, then a null statement is required in addition, as + in: + + ... + if J > 3 then + pragma Assert (K > 3, "Bad value for K"); + null; + end if; + + Note that, as with the `if' statement to which it is equivalent, + the type of the expression is either `Standard.Boolean', or any + type derived from this standard type. + + If assertions are disabled (switch `-gnata' not used), then there + is no effect (and in particular, any side effects from the + expression are suppressed). More precisely it is not quite true + that the pragma has no effect, since the expression is analyzed, + and may cause types to be frozen if they are mentioned here for + the first time. + + If assertions are enabled, then the given expression is tested, + and if it is `False' then `System.Assertions.Raise_Assert_Failure' + is called which results in the raising of `Assert_Failure' with + the given message. + + If the boolean expression has side effects, these side effects + will turn on and off with the setting of the assertions mode, + resulting in assertions that have an effect on the program. You + should generally avoid side effects in the expression arguments of + this pragma. However, the expressions are analyzed for semantic + correctness whether or not assertions are enabled, so turning + assertions on and off cannot affect the legality of a program. + + `pragma Ast_Entry' + Syntax: + + pragma AST_Entry (entry_IDENTIFIER); + + This pragma is implemented only in the OpenVMS implementation of + GNAT. The argument is the simple name of a single entry; at most + one `AST_Entry' pragma is allowed for any given entry. This + pragma must be used in conjunction with the `AST_Entry' attribute, + and is only allowed after the entry declaration and in the same + task type specification or single task as the entry to which it + applies. This pragma specifies that the given entry may be used + to handle an OpenVMS asynchronous system trap (`AST') resulting + from an OpenVMS system service call. The pragma does not affect + normal use of the entry. For further details on this pragma, see + the DEC Ada Language Reference Manual, section 9.12a. + + `pragma C_Pass_By_Copy' + Syntax: + + pragma C_Pass_By_Copy + ([Max_Size =>] static_integer_EXPRESSION); + + Normally the default mechanism for passing C convention records to + C convention subprograms is to pass them by reference, as + suggested by RM B.3(69). Use the configuration pragma + `C_Pass_By_Copy' to change this default, by requiring that record + formal parameters be passed by copy if all of the following + conditions are met: + + * The size of the record type does not exceed + STATIC_INTEGER_EXPRESSION. + + * The record type has `Convention C'. + + * The formal parameter has this record type, and the subprogram + has a foreign (non-Ada) convention. + + If these conditions are met the argument is passed by copy, i.e. + in a manner consistent with what C expects if the corresponding + formal in the C prototype is a struct (rather than a pointer to a + struct). + + You can also pass records by copy by specifying the convention + `C_Pass_By_Copy' for the record type, or by using the extended + `Import' and `Export' pragmas, which allow specification of + passing mechanisms on a parameter by parameter basis. + + `pragma Comment' + Syntax: + + pragma Comment (static_string_EXPRESSION); + + This is almost identical in effect to pragma `Ident'. It allows + the placement of a comment into the object file and hence into the + executable file if the operating system permits such usage. The + difference is that `Comment', unlike `Ident', has no limit on the + length of the string argument, and no limitations on placement of + the pragma (it can be placed anywhere in the main source unit). + + `pragma Common_Object' + Syntax: + + pragma Common_Object ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Size =>] EXTERNAL_SYMBOL] ) + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + This pragma enables the shared use of variables stored in overlaid + linker areas corresponding to the use of `COMMON' in Fortran. The + single object LOCAL_NAME is assigned to the area designated by the + EXTERNAL argument. You may define a record to correspond to a + series of fields. The SIZE argument is syntax checked in GNAT, + but otherwise ignored. + + `Common_Object' is not supported on all platforms. If no support + is available, then the code generator will issue a message + indicating that the necessary attribute for implementation of this + pragma is not available. + + `pragma Complex_Representation' + Syntax: + + pragma Complex_Representation + ([Entity =>] LOCAL_NAME); + + The ENTITY argument must be the name of a record type which has + two fields of the same floating-point type. The effect of this + pragma is to force gcc to use the special internal complex + representation form for this record, which may be more efficient. + Note that this may result in the code for this type not conforming + to standard ABI (application binary interface) requirements for + the handling of record types. For example, in some environments, + there is a requirement for passing records by pointer, and the use + of this pragma may result in passing this type in floating-point + registers. + + `pragma Component_Alignment' + Syntax: + + pragma Component_Alignment ( + [Form =>] ALIGNMENT_CHOICE + [, [Name =>] type_LOCAL_NAME]); + + ALIGNMENT_CHOICE ::= + Component_Size + | Component_Size_4 + | Storage_Unit + | Default + + Specifies the alignment of components in array or record types. + The meaning of the FORM argument is as follows: + + `Component_Size' + Aligns scalar components and subcomponents of the array or + record type on boundaries appropriate to their inherent size + (naturally aligned). For example, 1-byte components are + aligned on byte boundaries, 2-byte integer components are + aligned on 2-byte boundaries, 4-byte integer components are + aligned on 4-byte boundaries and so on. These alignment + rules correspond to the normal rules for C compilers on all + machines except the VAX. + + `Component_Size_4' + Naturally aligns components with a size of four or fewer + bytes. Components that are larger than 4 bytes are placed on + the next 4-byte boundary. + + `Storage_Unit' + Specifies that array or record components are byte aligned, + i.e. aligned on boundaries determined by the value of the + constant `System.Storage_Unit'. + + `Default' + Specifies that array or record components are aligned on + default boundaries, appropriate to the underlying hardware or + operating system or both. For OpenVMS VAX systems, the + `Default' choice is the same as the `Storage_Unit' choice + (byte alignment). For all other systems, the `Default' + choice is the same as `Component_Size' (natural alignment). + + If the `Name' parameter is present, TYPE_LOCAL_NAME must refer to + a local record or array type, and the specified alignment choice + applies to the specified type. The use of `Component_Alignment' + together with a pragma `Pack' causes the `Component_Alignment' + pragma to be ignored. The use of `Component_Alignment' together + with a record representation clause is only effective for fields + not specified by the representation clause. + + If the `Name' parameter is absent, the pragma can be used as either + a configuration pragma, in which case it applies to one or more + units in accordance with the normal rules for configuration + pragmas, or it can be used within a declarative part, in which + case it applies to types that are declared within this declarative + part, or within any nested scope within this declarative part. In + either case it specifies the alignment to be applied to any record + or array type which has otherwise standard representation. + + If the alignment for a record or array type is not specified (using + pragma `Pack', pragma `Component_Alignment', or a record rep + clause), the GNAT uses the default alignment as described + previously. + + `pragma Convention_Identifier' + Syntax: + + pragma Convention_Identifier ( + [Name =>] IDENTIFIER, + [Convention =>] convention_IDENTIFIER); + + This pragma provides a mechanism for supplying synonyms for + existing convention identifiers. The `Name' identifier can + subsequently be used as a synonym for the given convention in + other pragmas (including for example pragma `Import' or another + `Convention_Identifier' pragma). As an example of the use of this, + suppose you had legacy code which used Fortran77 as the identifier + for Fortran. Then the pragma: + + pragma Convention_Indentifier (Fortran77, Fortran); + + would allow the use of the convention identifier `Fortran77' in + subsequent code, avoiding the need to modify the sources. As + another example, you could use this to parametrize convention + requirements according to systems. Suppose you needed to use + `Stdcall' on windows systems, and `C' on some other system, then + you could define a convention identifier `Library' and use a single + `Convention_Identifier' pragma to specify which convention would + be used system-wide. + + `pragma CPP_Class' + Syntax: + + pragma CPP_Class ([Entity =>] LOCAL_NAME); + + The argument denotes an entity in the current declarative region + that is declared as a tagged or untagged record type. It + indicates that the type corresponds to an externally declared C++ + class type, and is to be laid out the same way that C++ would lay + out the type. + + If (and only if) the type is tagged, at least one component in the + record must be of type `Interfaces.CPP.Vtable_Ptr', corresponding + to the C++ Vtable (or Vtables in the case of multiple inheritance) + used for dispatching. + + Types for which `CPP_Class' is specified do not have assignment or + equality operators defined (such operations can be imported or + declared as subprograms as required). Initialization is allowed + only by constructor functions (see pragma `CPP_Constructor'). + + Pragma `CPP_Class' is intended primarily for automatic generation + using an automatic binding generator tool. See *Note Interfacing + to C++:: for related information. + + `pragma CPP_Constructor' + Syntax: + + pragma CPP_Constructor ([Entity =>] LOCAL_NAME); + + This pragma identifies an imported function (imported in the usual + way with pragma `Import') as corresponding to a C++ constructor. + The argument is a name that must have been previously mentioned in + a pragma `Import' with `Convention' = `CPP', and must be of one of + the following forms: + + * `function FNAME return T'Class' + + * `function FNAME (...) return T'Class' + + where T is a tagged type to which the pragma `CPP_Class' applies. + + The first form is the default constructor, used when an object of + type T is created on the Ada side with no explicit constructor. + Other constructors (including the copy constructor, which is + simply a special case of the second form in which the one and only + argument is of type T), can only appear in two contexts: + + * On the right side of an initialization of an object of type T. + + * In an extension aggregate for an object of a type derived + from T. + + Although the constructor is described as a function that returns a + value on the Ada side, it is typically a procedure with an extra + implicit argument (the object being initialized) at the + implementation level. GNAT issues the appropriate call, whatever + it is, to get the object properly initialized. + + In the case of derived objects, you may use one of two possible + forms for declaring and creating an object: + + * `New_Object : Derived_T' + + * `New_Object : Derived_T := (CONSTRUCTOR-FUNCTION-CALL WITH + ...)' + + In the first case the default constructor is called and extension + fields if any are initialized according to the default + initialization expressions in the Ada declaration. In the second + case, the given constructor is called and the extension aggregate + indicates the explicit values of the extension fields. + + If no constructors are imported, it is impossible to create any + objects on the Ada side. If no default constructor is imported, + only the initialization forms using an explicit call to a + constructor are permitted. + + Pragma `CPP_Constructor' is intended primarily for automatic + generation using an automatic binding generator tool. See *Note + Interfacing to C++:: for more related information. + + `pragma CPP_Virtual' + Syntax: + + pragma CPP_Virtual + [Entity =>] ENTITY, + [, [Vtable_Ptr =>] vtable_ENTITY,] + [, [Position =>] static_integer_EXPRESSION]) + + This pragma serves the same function as pragma `Import' in that + case of a virtual function imported from C++. The ENTITY argument + must be a primitive subprogram of a tagged type to which pragma + `CPP_Class' applies. The VTABLE_PTR argument specifies the + Vtable_Ptr component which contains the entry for this virtual + function. The POSITION argument is the sequential number counting + virtual functions for this Vtable starting at 1. + + The `Vtable_Ptr' and `Position' arguments may be omitted if there + is one Vtable_Ptr present (single inheritance case) and all + virtual functions are imported. In that case the compiler can + deduce both these values. + + No `External_Name' or `Link_Name' arguments are required for a + virtual function, since it is always accessed indirectly via the + appropriate Vtable entry. + + Pragma `CPP_Virtual' is intended primarily for automatic generation + using an automatic binding generator tool. See *Note Interfacing + to C++:: for related information. + + `pragma CPP_Vtable' + Syntax: + + pragma CPP_Vtable ( + [Entity =>] ENTITY, + [Vtable_Ptr =>] vtable_ENTITY, + [Entry_Count =>] static_integer_EXPRESSION); + + Given a record to which the pragma `CPP_Class' applies, this + pragma can be specified for each component of type + `CPP.Interfaces.Vtable_Ptr'. ENTITY is the tagged type, VTABLE_PTR + is the record field of type `Vtable_Ptr', and ENTRY_COUNT is the + number of virtual functions on the C++ side. Not all of these + functions need to be imported on the Ada side. + + You may omit the `CPP_Vtable' pragma if there is only one + `Vtable_Ptr' component in the record and all virtual functions are + imported on the Ada side (the default value for the entry count in + this case is simply the total number of virtual functions). + + Pragma `CPP_Vtable' is intended primarily for automatic generation + using an automatic binding generator tool. See *Note Interfacing + to C++:: for related information. + + `pragma Debug' + Syntax: + + pragma Debug (PROCEDURE_CALL_WITHOUT_SEMICOLON); + + PROCEDURE_CALL_WITHOUT_SEMICOLON ::= + PROCEDURE_NAME + | PROCEDURE_PREFIX ACTUAL_PARAMETER_PART + + The argument has the syntactic form of an expression, meeting the + syntactic requirements for pragmas. + + If assertions are not enabled on the command line, this pragma has + no effect. If asserts are enabled, the semantics of the pragma is + exactly equivalent to the procedure call statement corresponding + to the argument with a terminating semicolon. Pragmas are + permitted in sequences of declarations, so you can use pragma + `Debug' to intersperse calls to debug procedures in the middle of + declarations. + + `pragma Elaboration_Checks' + Syntax: + + pragma Elaboration_Checks (RM | Static); + + This is a configuration pragma that provides control over the + elaboration model used by the compilation affected by the pragma. + If the parameter is RM, then the dynamic elaboration model + described in the Ada Reference Manual is used, as though the + `-gnatE' switch had been specified on the command line. If the + parameter is Static, then the default GNAT static model is used. + This configuration pragma overrides the setting of the command + line. For full details on the elaboration models used by the GNAT + compiler, see section "Elaboration Order Handling in GNAT" in the + `GNAT User's Guide'. + + `pragma Eliminate' + Syntax: + + pragma Eliminate ( + [Unit_Name =>] IDENTIFIER | + SELECTED_COMPONENT); + + pragma Eliminate ( + [Unit_Name =>] IDENTIFIER | + SELECTED_COMPONENT, + [Entity =>] IDENTIFIER | + SELECTED_COMPONENT | + STRING_LITERAL + [,[Parameter_Types =>] PARAMETER_TYPES] + [,[Result_Type =>] result_SUBTYPE_NAME] + [,[Homonym_Number =>] INTEGER_LITERAL]); + + PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) + SUBTYPE_NAME ::= STRING_LITERAL + + This pragma indicates that the given entity is not used outside the + compilation unit it is defined in. The entity may be either a + subprogram or a variable. + + If the entity to be eliminated is a library level subprogram, then + the first form of pragma `Eliminate' is used with only a single + argument. In this form, the `Unit_Name' argument specifies the + name of the library level unit to be eliminated. + + In all other cases, both `Unit_Name' and `Entity' arguments are + required. item is an entity of a library package, then the first + argument specifies the unit name, and the second argument specifies + the particular entity. If the second argument is in string form, + it must correspond to the internal manner in which GNAT stores + entity names (see compilation unit Namet in the compiler sources + for details). + + The remaining parameters are optionally used to distinguish + between overloaded subprograms. There are two ways of doing this. + + Use `Parameter_Types' and `Result_Type' to specify the profile of + the subprogram to be eliminated in a manner similar to that used + for the extended `Import' and `Export' pragmas, except that the + subtype names are always given as string literals, again + corresponding to the internal manner in which GNAT stores entity + names. + + Alternatively, the `Homonym_Number' parameter is used to specify + which overloaded alternative is to be eliminated. A value of 1 + indicates the first subprogram (in lexical order), 2 indicates the + second etc. + + The effect of the pragma is to allow the compiler to eliminate the + code or data associated with the named entity. Any reference to + an eliminated entity outside the compilation unit it is defined in, + causes a compile time or link time error. + + The parameters of this pragma may be given in any order, as long as + the usual rules for use of named parameters and position parameters + are used. + + The intention of pragma `Eliminate' is to allow a program to be + compiled in a system independent manner, with unused entities + eliminated, without the requirement of modifying the source text. + Normally the required set of `Eliminate' pragmas is constructed + automatically using the gnatelim tool. Elimination of unused + entities local to a compilation unit is automatic, without + requiring the use of pragma `Eliminate'. + + Note that the reason this pragma takes string literals where names + might be expected is that a pragma `Eliminate' can appear in a + context where the relevant names are not visible. + + `pragma Export_Exception' + Syntax: + + pragma Export_Exception ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL,] + [, [Form =>] Ada | VMS] + [, [Code =>] static_integer_EXPRESSION]); + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + This pragma is implemented only in the OpenVMS implementation of + GNAT. It causes the specified exception to be propagated outside + of the Ada program, so that it can be handled by programs written + in other OpenVMS languages. This pragma establishes an external + name for an Ada exception and makes the name available to the + OpenVMS Linker as a global symbol. For further details on this + pragma, see the DEC Ada Language Reference Manual, section + 13.9a3.2. + + `pragma Export_Function ...' + Syntax: + + pragma Export_Function ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Result_Type =>] result_SUBTYPE_MARK] + [, [Mechanism =>] MECHANISM] + [, [Result_Mechanism =>] MECHANISM_NAME]); + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + PARAMETER_TYPES ::= + null + | SUBTYPE_MARK {, SUBTYPE_MARK} + + MECHANISM ::= + MECHANISM_NAME + | (MECHANISM_ASSOCIATION {, MECHANISM_ASSOCIATION}) + + MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + + MECHANISM_NAME ::= + Value + | Reference + | Descriptor [([Class =>] CLASS_NAME)] + + CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + Use this pragma to make a function externally callable and + optionally provide information on mechanisms to be used for + passing parameter and result values. We recommend, for the + purposes of improving portability, this pragma always be used in + conjunction with a separate pragma `Export', which must precede + the pragma `Export_Function'. GNAT does not require a separate + pragma `Export', but if none is present, `Convention Ada' is + assumed, which is usually not what is wanted, so it is usually + appropriate to use this pragma in conjunction with a `Export' or + `Convention' pragma that specifies the desired foreign convention. + Pragma `Export_Function' (and `Export', if present) must appear in + the same declarative region as the function to which they apply. + + INTERNAL_NAME must uniquely designate the function to which the + pragma applies. If more than one function name exists of this + name in the declarative part you must use the `Parameter_Types' and + `Result_Type' parameters is mandatory to achieve the required + unique designation. SUBTYPE_ MARKs in these parameters must + exactly match the subtypes in the corresponding function + specification, using positional notation to match parameters with + subtype marks. Passing by descriptor is supported only on the + OpenVMS ports of GNAT. + + `pragma Export_Object ...' + Syntax: + + pragma Export_Object + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Size =>] EXTERNAL_SYMBOL] + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + This pragma designates an object as exported, and apart from the + extended rules for external symbols, is identical in effect to the + use of the normal `Export' pragma applied to an object. You may + use a separate Export pragma (and you probably should from the + point of view of portability), but it is not required. SIZE is + syntax checked, but otherwise ignored by GNAT. + + `pragma Export_Procedure ...' + Syntax: + + pragma Export_Procedure ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Mechanism =>] MECHANISM]); + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + PARAMETER_TYPES ::= + null + | SUBTYPE_MARK {, SUBTYPE_MARK} + + MECHANISM ::= + MECHANISM_NAME + | (MECHANISM_ASSOCIATION {, MECHANISM_ASSOCIATION}) + + MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + + MECHANISM_NAME ::= + Value + | Reference + | Descriptor [([Class =>] CLASS_NAME)] + + CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + This pragma is identical to `Export_Function' except that it + applies to a procedure rather than a function and the parameters + `Result_Type' and `Result_Mechanism' are not permitted. GNAT does + not require a separate pragma `Export', but if none is present, + `Convention Ada' is assumed, which is usually not what is wanted, + so it is usually appropriate to use this pragma in conjunction + with a `Export' or `Convention' pragma that specifies the desired + foreign convention. + + `pragma Export_Valued_Procedure' + Syntax: + + pragma Export_Valued_Procedure ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Mechanism =>] MECHANISM]); + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + PARAMETER_TYPES ::= + null + | SUBTYPE_MARK {, SUBTYPE_MARK} + + MECHANISM ::= + MECHANISM_NAME + | (MECHANISM_ASSOCIATION {, MECHANISM_ASSOCIATION}) + + MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + + MECHANISM_NAME ::= + Value + | Reference + | Descriptor [([Class =>] CLASS_NAME)] + + CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + This pragma is identical to `Export_Procedure' except that the + first parameter of LOCAL_NAME, which must be present, must be of + mode `OUT', and externally the subprogram is treated as a function + with this parameter as the result of the function. GNAT provides + for this capability to allow the use of `OUT' and `IN OUT' + parameters in interfacing to external functions (which are not + permitted in Ada functions). GNAT does not require a separate + pragma `Export', but if none is present, `Convention Ada' is + assumed, which is almost certainly not what is wanted since the + whole point of this pragma is to interface with foreign language + functions, so it is usually appropriate to use this pragma in + conjunction with a `Export' or `Convention' pragma that specifies + the desired foreign convention. + + `pragma Extend_System' + Syntax: + + pragma Extend_System ([Name =>] IDENTIFIER); + + This pragma is used to provide backwards compatibility with other + implementations that extend the facilities of package `System'. In + GNAT, `System' contains only the definitions that are present in + the Ada 95 RM. However, other implementations, notably the DEC + Ada 83 implementation, provide many extensions to package `System'. + + For each such implementation accommodated by this pragma, GNAT + provides a package `Aux_XXX', e.g. `Aux_DEC' for the DEC Ada 83 + implementation, which provides the required additional + definitions. You can use this package in two ways. You can + `with' it in the normal way and access entities either by + selection or using a `use' clause. In this case no special + processing is required. + + However, if existing code contains references such as `System.XXX' + where XXX is an entity in the extended definitions provided in + package `System', you may use this pragma to extend visibility in + `System' in a non-standard way that provides greater compatibility + with the existing code. Pragma `Extend_System' is a configuration + pragma whose single argument is the name of the package containing + the extended definition (e.g. `Aux_DEC' for the DEC Ada case). A + unit compiled under control of this pragma will be processed using + special visibility processing that looks in package + `System.Aux_XXX' where `Aux_XXX' is the pragma argument for any + entity referenced in package `System', but not found in package + `System'. + + You can use this pragma either to access a predefined `System' + extension supplied with the compiler, for example `Aux_DEC' or you + can construct your own extension unit following the above + definition. Note that such a package is a child of `System' and + thus is considered part of the implementation. To compile it you + will have to use the appropriate switch for compiling system + units. See the GNAT User's Guide for details. + + `pragma External' + Syntax: + + pragma External ( + [ Convention =>] convention_IDENTIFIER, + [ Entity =>] local_NAME + [, [External_Name =>] static_string_EXPRESSION ] + [, [Link_Name =>] static_string_EXPRESSION ]); + + This pragma is identical in syntax and semantics to pragma + `Export' as defined in the Ada Reference Manual. It is provided + for compatibility with some Ada 83 compilers that used this pragma + for exactly the same purposes as pragma `Export' before the latter + was standardized. + + `pragma External_Name_Casing' + Syntax: + + pragma External_Name_Casing ( + Uppercase | Lowercase + [, Uppercase | Lowercase | As_Is]); + + This pragma provides control over the casing of external names + associated with Import and Export pragmas. There are two cases to + consider: + + Implicit external names + Implicit external names are derived from identifiers. The + most common case arises when a standard Ada 95 Import or + Export pragma is used with only two arguments, as in: + + pragma Import (C, C_Routine); + + Since Ada is a case insensitive language, the spelling of the + identifier in the Ada source program does not provide any + information on the desired casing of the external name, and + so a convention is needed. In GNAT the default treatment is + that such names are converted to all lower case letters. + This corresponds to the normal C style in many environments. + The first argument of pragma `External_Name_Casing' can be + used to control this treatment. If `Uppercase' is specified, + then the name will be forced to all uppercase letters. If + `Lowercase' is specified, then the normal default of all + lower case letters will be used. + + This same implicit treatment is also used in the case of + extended DEC Ada 83 compatible Import and Export pragmas + where an external name is explicitly specified using an + identifier rather than a string. + + Explicit external names + Explicit external names are given as string literals. The + most common case arises when a standard Ada 95 Import or + Export pragma is used with three arguments, as in: + + pragma Import (C, C_Routine, "C_routine"); + + In this case, the string literal normally provides the exact + casing required for the external name. The second argument + of pragma `External_Name_Casing' may be used to modify this + behavior. If `Uppercase' is specified, then the name will be + forced to all uppercase letters. If `Lowercase' is specified, + then the name will be forced to all lowercase letters. A + specification of `As_Is' provides the normal default behavior + in which the casing is taken from the string provided. + + This pragma may appear anywhere that a pragma is valid. In + particular, it can be used as a configuration pragma in the + `gnat.adc' file, in which case it applies to all subsequent + compilations, or it can be used as a program unit pragma, in which + case it only applies to the current unit, or it can be used more + locally to control individual Import/Export pragmas. + + It is primarily intended for use with OpenVMS systems, where many + compilers convert all symbols to upper case by default. For + interfacing to such compilers (e.g. the DEC C compiler), it may be + convenient to use the pragma: + + pragma External_Name_Casing (Uppercase, Uppercase); + + to enforce the upper casing of all external symbols. + + `pragma Finalize_Storage_Only' + Syntax: + + pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); + + This pragma allows the compiler not to emit a Finalize call for + objects defined at the library level. This is mostly useful for + types where finalization is only used to deal with storage + reclamation since in most environments it is not necessary to + reclaim memory just before terminating execution, hence the name. + + `pragma Float_Representation' + Syntax: + + pragma Float_Representation (FLOAT_REP); + + FLOAT_REP ::= VAX_Float | IEEE_Float + + This pragma is implemented only in the OpenVMS implementation of + GNAT. It allows control over the internal representation chosen + for the predefined floating point types declared in the packages + `Standard' and `System'. For further details on this pragma, see + the DEC Ada Language Reference Manual, section 3.5.7a. Note that + to use this pragma, the standard runtime libraries must be + recompiled. See the description of the `GNAT LIBRARY' command in + the OpenVMS version of the GNAT Users Guide for details on the use + of this command. + + `pragma Ident' + Syntax: + + pragma Ident (static_string_EXPRESSION); + + This pragma provides a string identification in the generated + object file, if the system supports the concept of this kind of + identification string. The maximum permitted length of the string + literal is 31 characters. This pragma is allowed only in the + outermost declarative part or declarative items of a compilation + unit. On OpenVMS systems, the effect of the pragma is identical + to the effect of the DEC Ada 83 pragma of the same name. + + `pragma Import_Exception' + Syntax: + + pragma Import_Exception ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL,] + [, [Form =>] Ada | VMS] + [, [Code =>] static_integer_EXPRESSION]); + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + This pragma is implemented only in the OpenVMS implementation of + GNAT. It allows OpenVMS conditions (for example, from OpenVMS + system services or other OpenVMS languages) to be propagated to + Ada programs as Ada exceptions. The pragma specifies that the + exception associated with an exception declaration in an Ada + program be defined externally (in non-Ada code). For further + details on this pragma, see the DEC Ada Language Reference Manual, + section 13.9a.3.1. + + `pragma Import_Function ...' + Syntax: + + pragma Import_Function ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Result_Type =>] SUBTYPE_MARK] + [, [Mechanism =>] MECHANISM] + [, [Result_Mechanism =>] MECHANISM_NAME] + [, [First_Optional_Parameter =>] IDENTIFIER]); + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + PARAMETER_TYPES ::= + null + | SUBTYPE_MARK {, SUBTYPE_MARK} + + MECHANISM ::= + MECHANISM_NAME + | (MECHANISM_ASSOCIATION {, MECHANISM_ASSOCIATION}) + + MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + + MECHANISM_NAME ::= + Value + | Reference + | Descriptor [([Class =>] CLASS_NAME)] + + CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + This pragma is used in conjunction with a pragma `Import' to + specify additional information for an imported function. The + pragma `Import' (or equivalent pragma `Interface') must precede the + `Import_Function' pragma and both must appear in the same + declarative part as the function specification. + + The INTERNAL_NAME argument must uniquely designate the function to + which the pragma applies. If more than one function name exists + of this name in the declarative part you must use the + `Parameter_Types' and RESULT_TYPE parameters to achieve the + required unique designation. Subtype marks in these parameters + must exactly match the subtypes in the corresponding function + specification, using positional notation to match parameters with + subtype marks. + + You may optionally use the MECHANISM and RESULT_MECHANISM + parameters to specify passing mechanisms for the parameters and + result. If you specify a single mechanism name, it applies to all + parameters. Otherwise you may specify a mechanism on a parameter + by parameter basis using either positional or named notation. If + the mechanism is not specified, the default mechanism is used. + + Passing by descriptor is supported only on the to OpenVMS ports of + GNAT. + + `First_Optional_Parameter' applies only to OpenVMS ports of GNAT. + It specifies that the designated parameter and all following + parameters are optional, meaning that they are not passed at the + generated code level (this is distinct from the notion of optional + parameters in Ada where the parameters are passed anyway with the + designated optional parameters). All optional parameters must be + of mode `IN' and have default parameter values that are either + known at compile time expressions, or uses of the + `'Null_Parameter' attribute. + + `pragma Import_Object' + Syntax: + + pragma Import_Object + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL], + [, [Size =>] EXTERNAL_SYMBOL]) + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + This pragma designates an object as imported, and apart from the + extended rules for external symbols, is identical in effect to the + use of the normal `Import' pragma applied to an object. Unlike the + subprogram case, you need not use a separate `Import' pragma, + although you may do so (and probably should do so from a + portability point of view). SIZE is syntax checked, but otherwise + ignored by GNAT. + + `pragma Import_Procedure' + Syntax: + + pragma Import_Procedure ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Mechanism =>] MECHANISM] + [, [First_Optional_Parameter =>] IDENTIFIER]); + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + PARAMETER_TYPES ::= + null + | SUBTYPE_MARK {, SUBTYPE_MARK} + + MECHANISM ::= + MECHANISM_NAME + | (MECHANISM_ASSOCIATION {, MECHANISM_ASSOCIATION}) + + MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + + MECHANISM_NAME ::= + Value + | Reference + | Descriptor [([Class =>] CLASS_NAME)] + + CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + This pragma is identical to `Import_Function' except that it + applies to a procedure rather than a function and the parameters + `Result_Type' and `Result_Mechanism' are not permitted. + + `pragma Import_Valued_Procedure ...' + Syntax: + + pragma Import_Valued_Procedure ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Mechanism =>] MECHANISM] + [, [First_Optional_Parameter =>] IDENTIFIER]); + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + PARAMETER_TYPES ::= + null + | SUBTYPE_MARK {, SUBTYPE_MARK} + + MECHANISM ::= + MECHANISM_NAME + | (MECHANISM_ASSOCIATION {, MECHANISM_ASSOCIATION}) + + MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + + MECHANISM_NAME ::= + Value + | Reference + | Descriptor [([Class =>] CLASS_NAME)] + + CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + This pragma is identical to `Import_Procedure' except that the + first parameter of LOCAL_NAME, which must be present, must be of + mode `OUT', and externally the subprogram is treated as a function + with this parameter as the result of the function. The purpose of + this capability is to allow the use of `OUT' and `IN OUT' + parameters in interfacing to external functions (which are not + permitted in Ada functions). You may optionally use the + `Mechanism' parameters to specify passing mechanisms for the + parameters. If you specify a single mechanism name, it applies to + all parameters. Otherwise you may specify a mechanism on a + parameter by parameter basis using either positional or named + notation. If the mechanism is not specified, the default + mechanism is used. + + Note that it is important to use this pragma in conjunction with a + separate pragma Import that specifies the desired convention, + since otherwise the default convention is Ada, which is almost + certainly not what is required. + + `pragma Initialize_Scalars' + Syntax: + + pragma Initialize_Scalars; + + This pragma is similar to `Normalize_Scalars' conceptually but has + two important differences. First, there is no requirement for the + pragma to be used uniformly in all units of a partition, in + particular, it is fine to use this just for some or all of the + application units of a partition, without needing to recompile the + run-time library. + + In the case where some units are compiled with the pragma, and + some without, then a declaration of a variable where the type is + defined in package Standard or is locally declared will always be + subject to initialization, as will any declaration of a scalar + variable. For composite variables, whether the variable is + initialized may also depend on whether the package in which the + type of the variable is declared is compiled with the pragma. + + The other important difference is that there is control over the + value used for initializing scalar objects. At bind time, you can + select whether to initialize with invalid values (like + Normalize_Scalars), or with high or low values, or with a + specified bit pattern. See the users guide for binder options for + specifying these cases. + + This means that you can compile a program, and then without having + to recompile the program, you can run it with different values + being used for initializing otherwise uninitialized values, to + test if your program behavior depends on the choice. Of course + the behavior should not change, and if it does, then most likely + you have an erroneous reference to an uninitialized value. + + Note that pragma `Initialize_Scalars' is particularly useful in + conjunction with the enhanced validity checking that is now + provided in GNAT, which checks for invalid values under more + conditions. Using this feature (see description of the `-gnatv' + flag in the users guide) in conjunction with pragma + `Initialize_Scalars' provides a powerful new tool to assist in the + detection of problems caused by uninitialized variables. + + `pragma Inline_Always' + Syntax: + + pragma Inline_Always (NAME [, NAME]); + + Similar to pragma `Inline' except that inlining is not subject to + the use of option `-gnatn' for inter-unit inlining. + + `pragma Inline_Generic' + Syntax: + + pragma Inline_Generic (generic_package_NAME) + + This is implemented for compatibility with DEC Ada 83 and is + recognized, but otherwise ignored, by GNAT. All generic + instantiations are inlined by default when using GNAT. + + `pragma Interface' + Syntax: + + pragma Interface ( + [Convention =>] convention_identifier, + [Entity =>] local_name + [, [External_Name =>] static_string_expression], + [, [Link_Name =>] static_string_expression]); + + This pragma is identical in syntax and semantics to the standard + Ada 95 pragma `Import'. It is provided for compatibility with Ada + 83. The definition is upwards compatible both with pragma + `Interface' as defined in the Ada 83 Reference Manual, and also + with some extended implementations of this pragma in certain Ada 83 + implementations. + + `pragma Interface_Name' + Syntax: + + pragma Interface_Name ( + [Entity =>] LOCAL_NAME + [, [External_Name =>] static_string_EXPRESSION] + [, [Link_Name =>] static_string_EXPRESSION]); + + This pragma provides an alternative way of specifying the + interface name for an interfaced subprogram, and is provided for + compatibility with Ada 83 compilers that use the pragma for this + purpose. You must provide at least one of EXTERNAL_NAME or + LINK_NAME. + + `pragma License' + Syntax: + + pragma License (Unrestricted | GPL | Modified_GPL | Restricted); + + This pragma is provided to allow automated checking for + appropriate license conditions with respect to the standard and + modified GPL. A pragma `License', which is a configuration pragma + that typically appears at the start of a source file or in a + separate `gnat.adc' file, specifies the licensing conditions of a + unit as follows: + + * Unrestricted This is used for a unit that can be freely used + with no license restrictions. Examples of such units are + public domain units, and units from the Ada Reference Manual. + + * GPL This is used for a unit that is licensed under the + unmodified GPL, and which therefore cannot be `with''ed by a + restricted unit. + + * Modified_GPL This is used for a unit licensed under the GNAT + modified GPL that includes a special exception paragraph that + specifically permits the inclusion of the unit in programs + without requiring the entire program to be released under the + GPL. This is the license used for the GNAT run-time which + ensures that the run-time can be used freely in any program + without GPL concerns. + + * Restricted This is used for a unit that is restricted in that + it is not permitted to depend on units that are licensed + under the GPL. Typical examples are proprietary code that is + to be released under more restrictive license conditions. + Note that restricted units are permitted to `with' units + which are licensed under the modified GPL (this is the whole + point of the modified GPL). + + + Normally a unit with no `License' pragma is considered to have an + unknown license, and no checking is done. However, standard GNAT + headers are recognized, and license information is derived from + them as follows. + + A GNAT license header starts with a line containing 78 + hyphens. The following comment text is searched for the + appearence of any of the following strings. + + If the string "GNU General Public License" is found, then the + unit is assumed to have GPL license, unless the string "As a + special exception" follows, in which case the license is + assumed to be modified GPL. + + If one of the strings "This specification is adapated from + the Ada Semantic Interface" or "This specification is derived + from the Ada Reference Manual" is found then the unit is + assumed to be unrestricted. + + These default actions means that a program with a restricted + license pragma will automatically get warnings if a GPL unit is + inappropriately `with''ed. For example, the program: + + with Sem_Ch3; + with GNAT.Sockets; + procedure Secret_Stuff is + ... + end Secret_Stuff + + if compiled with pragma `License' (`Restricted') in a `gnat.adc' + file will generate the warning: + + 1. with Sem_Ch3; + | + >>> license of withed unit "Sem_Ch3" is incompatible + + 2. with GNAT.Sockets; + 3. procedure Secret_Stuff is + + Here we get a warning on `Sem_Ch3' since it is part of the GNAT + compiler and is licensed under the GPL, but no warning for + `GNAT.Sockets' which is part of the GNAT run time, and is + therefore licensed under the modified GPL. + + `pragma Link_With' + Syntax: + + pragma Link_With (static_string_EXPRESSION {,static_string_EXPRESSION}); + + This pragma is provided for compatibility with certain Ada 83 + compilers. It has exactly the same effect as pragma + `Linker_Options' except that spaces occurring within one of the + string expressions are treated as separators. For example, in the + following case: + + pragma Link_With ("-labc -ldef"); + + results in passing the strings `-labc' and `-ldef' as two separate + arguments to the linker. In addition pragma Link_With allows + multiple arguments, with the same effect as successive pragmas. + + `pragma Linker_Alias' + Syntax: + + pragma Linker_Alias ( + [Entity =>] LOCAL_NAME + [Alias =>] static_string_EXPRESSION); + + This pragma establishes a linker alias for the given named entity. + For further details on the exact effect, consult the GCC manual. + + `pragma Linker_Section' + Syntax: + + pragma Linker_Section ( + [Entity =>] LOCAL_NAME + [Section =>] static_string_EXPRESSION); + + This pragma specifies the name of the linker section for the given + entity. For further details on the exact effect, consult the GCC + manual. + + `pragma No_Run_Time' + Syntax: + + pragma No_Run_Time; + + This is a configuration pragma that makes sure the user code does + not use nor need anything from the GNAT run time. This is mostly + useful in context where code certification is required. Please + consult the `GNAT Pro High-Integrity Edition User's Guide' for + additional information. + + `pragma Normalize_Scalars' + Syntax: + + pragma Normalize_Scalars; + + This is a language defined pragma which is fully implemented in + GNAT. The effect is to cause all scalar objects that are not + otherwise initialized to be initialized. The initial values are + implementation dependent and are as follows: + + `Standard.Character' + Objects whose root type is Standard.Character are initialized + to Character'Last. This will be out of range of the subtype + only if the subtype range excludes this value. + + `Standard.Wide_Character' + Objects whose root type is Standard.Wide_Character are + initialized to Wide_Character'Last. This will be out of + range of the subtype only if the subtype range excludes this + value. + + `Integer types' + Objects of an integer type are initialized to + base_type'First, where base_type is the base type of the + object type. This will be out of range of the subtype only + if the subtype range excludes this value. For example, if + you declare the subtype: + + subtype Ityp is integer range 1 .. 10; + + then objects of type x will be initialized to Integer'First, + a negative number that is certainly outside the range of + subtype `Ityp'. + + `Real types' + Objects of all real types (fixed and floating) are + initialized to base_type'First, where base_Type is the base + type of the object type. This will be out of range of the + subtype only if the subtype range excludes this value. + + `Modular types' + Objects of a modular type are initialized to typ'Last. This + will be out of range of the subtype only if the subtype + excludes this value. + + `Enumeration types' + Objects of an enumeration type are initialized to all + one-bits, i.e. to the value `2 ** typ'Size - 1'. This will + be out of range of the enumeration subtype in all cases + except where the subtype contains exactly 2**8, 2**16, or + 2**32 elements. + + `pragma Long_Float' + Syntax: + + pragma Long_Float (FLOAT_FORMAT); + + FLOAT_FORMAT ::= D_Float | G_Float + + This pragma is implemented only in the OpenVMS implementation of + GNAT. It allows control over the internal representation chosen + for the predefined type `Long_Float' and for floating point type + representations with `digits' specified in the range 7 through 15. + For further details on this pragma, see the `DEC Ada Language + Reference Manual', section 3.5.7b. Note that to use this pragma, + the standard runtime libraries must be recompiled. See the + description of the `GNAT LIBRARY' command in the OpenVMS version + of the GNAT User's Guide for details on the use of this command. + + `pragma Machine_Attribute ...' + Syntax: + + pragma Machine_Attribute ( + [Attribute_Name =>] string_EXPRESSION, + [Entity =>] LOCAL_NAME); + + Machine dependent attributes can be specified for types and/or + declarations. Currently only subprogram entities are supported. + This pragma is semantically equivalent to + `__attribute__((STRING_EXPRESSION))' in GNU C, where + `STRING_EXPRESSION' is recognized by the GNU C macros + `VALID_MACHINE_TYPE_ATTRIBUTE' and `VALID_MACHINE_DECL_ATTRIBUTE' + which are defined in the configuration header file `tm.h' for each + machine. See the GCC manual for further information. + + `pragma Main_Storage' + Syntax: + + pragma Main_Storage + (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); + + MAIN_STORAGE_OPTION ::= + [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION + | [TOP_GUARD =>] static_SIMPLE_EXPRESSION + + This pragma is provided for compatibility with OpenVMS Vax + Systems. It has no effect in GNAT, other than being syntax + checked. Note that the pragma also has no effect in DEC Ada 83 + for OpenVMS Alpha Systems. + + `pragma No_Return' + Syntax: + + pragma No_Return (procedure_LOCAL_NAME); + + PROCEDURE_LOCAL_NAME must refer to one or more procedure + declarations in the current declarative part. A procedure to + which this pragma is applied may not contain any explicit `return' + statements, and also may not contain any implicit return + statements from falling off the end of a statement sequence. One + use of this pragma is to identify procedures whose only purpose is + to raise an exception. + + Another use of this pragma is to suppress incorrect warnings about + missing returns in functions, where the last statement of a + function statement sequence is a call to such a procedure. + + `pragma Passive' + Syntax: + + pragma Passive ([Semaphore | No]); + + Syntax checked, but otherwise ignored by GNAT. This is recognized + for compatibility with DEC Ada 83 implementations, where it is + used within a task definition to request that a task be made + passive. If the argument `Semaphore' is present, or no argument + is omitted, then DEC Ada 83 treats the pragma as an assertion that + the containing task is passive and that optimization of context + switch with this task is permitted and desired. If the argument + `No' is present, the task must not be optimized. GNAT does not + attempt to optimize any tasks in this manner (since protected + objects are available in place of passive tasks). + + `pragma Polling' + Syntax: + + pragma Polling (ON | OFF); + + This pragma controls the generation of polling code. This is + normally off. If `pragma Polling (ON)' is used then periodic + calls are generated to the routine `Ada.Exceptions.Poll'. This + routine is a separate unit in the runtime library, and can be + found in file `a-excpol.adb'. + + Pragma `Polling' can appear as a configuration pragma (for example + it can be placed in the `gnat.adc' file) to enable polling + globally, or it can be used in the statement or declaration + sequence to control polling more locally. + + A call to the polling routine is generated at the start of every + loop and at the start of every subprogram call. This guarantees + that the `Poll' routine is called frequently, and places an upper + bound (determined by the complexity of the code) on the period + between two `Poll' calls. + + The primary purpose of the polling interface is to enable + asynchronous aborts on targets that cannot otherwise support it + (for example Windows NT), but it may be used for any other purpose + requiring periodic polling. The standard version is null, and can + be replaced by a user program. This will require re-compilation + of the `Ada.Exceptions' package that can be found in files + `a-except.ads' and `a-except.adb'. + + A standard alternative unit (in file `4wexcpol.adb' in the + standard GNAT distribution) is used to enable the asynchronous + abort capability on targets that do not normally support the + capability. The version of `Poll' in this file makes a call to + the appropriate runtime routine to test for an abort condition. + + Note that polling can also be enabled by use of the `-gnatP' + switch. See the `GNAT User's Guide' for details. + + `pragma Propagate_Exceptions' + Syntax: + + pragma Propagate_Exceptions (subprogram_LOCAL_NAME); + + This pragma indicates that the given entity, which is the name of + an imported foreign-language subprogram may receive an Ada + exception, and that the exception should be propagated. It is + relevant only if zero cost exception handling is in use, and is + thus never needed if the alternative `longjmp' / `setjmp' + implementation of exceptions is used (although it is harmless to + use it in such cases). + + The implementation of fast exceptions always properly propagates + exceptions through Ada code, as described in the Ada Reference + Manual. However, this manual is silent about the propagation of + exceptions through foreign code. For example, consider the + situation where `P1' calls `P2', and `P2' calls `P3', where `P1' + and `P3' are in Ada, but `P2' is in C. `P3' raises an Ada + exception. The question is whether or not it will be propagated + through `P2' and can be handled in `P1'. + + For the `longjmp' / `setjmp' implementation of exceptions, the + answer is always yes. For some targets on which zero cost + exception handling is implemented, the answer is also always yes. + However, there are some targets, notably in the current version + all x86 architecture targets, in which the answer is that such + propagation does not happen automatically. If such propagation is + required on these targets, it is mandatory to use + `Propagate_Exceptions' to name all foreign language routines + through which Ada exceptions may be propagated. + + `pragma Psect_Object' + Syntax: + + pragma Psect_Object + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Size =>] EXTERNAL_SYMBOL] + + EXTERNAL_SYMBOL ::= + IDENTIFIER + | static_string_EXPRESSION + + This pragma is identical in effect to pragma `Common_Object'. + + `pragma Pure_Function' + Syntax: + + pragma Pure_Function ([Entity =>] function_LOCAL_NAME); + + This pragma appears in the same declarative part as a function + declaration (or a set of function declarations if more than one + overloaded declaration exists, in which case the pragma applies to + all entities). If specifies that the function `Entity' is to be + considered pure for the purposes of code generation. This means + that the compiler can assume that there are no side effects, and + in particular that two calls with identical arguments produce the + same result. It also means that the function can be used in an + address clause. + + Note that, quite deliberately, there are no static checks to try + to ensure that this promise is met, so `Pure_Function' can be used + with functions that are conceptually pure, even if they do modify + global variables. For example, a square root function that is + instrumented to count the number of times it is called is still + conceptually pure, and can still be optimized, even though it + modifies a global variable (the count). Memo functions are another + example (where a table of previous calls is kept and consulted to + avoid re-computation). + + Note: Most functions in a `Pure' package are automatically pure, + and there is no need to use pragma `Pure_Function' for such + functions. An exception is any function that has at least one + formal of type `System.Address' or a type derived from it. Such + functions are not considered pure by default, since the compiler + assumes that the `Address' parameter may be functioning as a + pointer and that the referenced data may change even if the + address value does not. The use of pragma `Pure_Function' for + such a function will override this default assumption, and cause + the compiler to treat such a function as pure. + + Note: If pragma `Pure_Function' is applied to a renamed function, + it applies to the underlying renamed function. This can be used to + disambiguate cases of overloading where some but not all functions + in a set of overloaded functions are to be designated as pure. + + `pragma Ravenscar' + Syntax: + + pragma Ravenscar + + A configuration pragma that establishes the following set of + restrictions: + + `No_Abort_Statements' + [RM D.7] There are no abort_statements, and there are no + calls to Task_Identification.Abort_Task. + + `No_Select_Statements' + There are no select_statements. + + `No_Task_Hierarchy' + [RM D.7] All (non-environment) tasks depend directly on the + environment task of the partition. + + `No_Task_Allocators' + [RM D.7] There are no allocators for task types or types + containing task subcomponents. + + `No_Dynamic_Priorities' + [RM D.7] There are no semantic dependencies on the package + Dynamic_Priorities. + + `No_Terminate_Alternatives' + [RM D.7] There are no selective_accepts with + terminate_alternatives + + `No_Dynamic_Interrupts' + There are no semantic dependencies on Ada.Interrupts. + + `No_Protected_Type_Allocators' + There are no allocators for protected types or types + containing protected subcomponents. + + `No_Local_Protected_Objects' + Protected objects and access types that designate such + objects shall be declared only at library level. + + `No_Requeue' + Requeue statements are not allowed. + + `No_Calendar' + There are no semantic dependencies on the package + Ada.Calendar. + + `No_Relative_Delay' + There are no delay_relative_statements. + + `No_Task_Attributes' + There are no semantic dependencies on the Ada.Task_Attributes + package and there are no references to the attributes + Callable and Terminated [RM 9.9]. + + `Static_Storage_Size' + The expression for pragma Storage_Size is static. + + `Boolean_Entry_Barriers' + Entry barrier condition expressions shall be boolean objects + which are declared in the protected type which contains the + entry. + + `Max_Asynchronous_Select_Nesting = 0' + [RM D.7] Specifies the maximum dynamic nesting level of + asynchronous_selects. A value of zero prevents the use of + any asynchronous_select. + + `Max_Task_Entries = 0' + [RM D.7] Specifies the maximum number of entries per task. + The bounds of every entry family of a task unit shall be + static, or shall be defined by a discriminant of a subtype + whose corresponding bound is static. A value of zero + indicates that no rendezvous are possible. For the Ravenscar + pragma, the value of Max_Task_Entries is always 0 (zero). + + `Max_Protected_Entries = 1' + [RM D.7] Specifies the maximum number of entries per + protected type. The bounds of every entry family of a + protected unit shall be static, or shall be defined by a + discriminant of a subtype whose corresponding bound is + static. For the Ravenscar pragma the value of + Max_Protected_Entries is always 1. + + `Max_Select_Alternatives = 0' + [RM D.7] Specifies the maximum number of alternatives in a + selective_accept. For the Ravenscar pragma the value if + always 0. + + `No_Task_Termination' + Tasks which terminate are erroneous. + + `No_Entry_Queue' + No task can be queued on a protected entry. Note that this + restrictions is checked at run time. The violation of this + restriction generates a Program_Error exception. + + This set of restrictions corresponds to the definition of the + "Ravenscar Profile" for limited tasking, devised and published by + the `International Real-Time Ada Workshop', 1997. + + The above set is a superset of the restrictions provided by pragma + `Restricted_Run_Time', it includes six additional restrictions + (`Boolean_Entry_Barriers', `No_Select_Statements', `No_Calendar', + `Static_Storage_Size', `No_Relative_Delay' and + `No_Task_Termination'). This means that pragma `Ravenscar', like + the pragma `Restricted_Run_Time', automatically causes the use of + a simplified, more efficient version of the tasking run-time + system. + + `pragma Restricted_Run_Time' + Syntax: + + pragma Restricted_Run_Time + + A configuration pragma that establishes the following set of + restrictions: + + * No_Abort_Statements + + * No_Asynchronous_Control + + * No_Entry_Queue + + * No_Task_Hierarchy + + * No_Task_Allocators + + * No_Dynamic_Priorities + + * No_Terminate_Alternatives + + * No_Dynamic_Interrupts + + * No_Protected_Type_Allocators + + * No_Local_Protected_Objects + + * No_Requeue + + * No_Task_Attributes + + * Max_Asynchronous_Select_Nesting = 0 + + * Max_Task_Entries = 0 + + * Max_Protected_Entries = 1 + + * Max_Select_Alternatives = 0 + + This set of restrictions causes the automatic selection of a + simplified version of the run time that provides improved + performance for the limited set of tasking functionality permitted + by this set of restrictions. + + `pragma Share_Generic' + Syntax: + + pragma Share_Generic (NAME {, NAME}); + + This pragma is recognized for compatibility with other Ada + compilers but is ignored by GNAT. GNAT does not provide the + capability for sharing of generic code. All generic + instantiations result in making an inlined copy of the template + with appropriate substitutions. + + `pragma Source_File_Name' + Syntax: + + pragma Source_File_Name ( + [Unit_Name =>] unit_NAME, + Spec_File_Name => STRING_LITERAL); + + pragma Source_File_Name ( + [Unit_Name =>] unit_NAME, + Body_File_Name => STRING_LITERAL); + + Use this to override the normal naming convention. It is a + configuration pragma, and so has the usual applicability of + configuration pragmas (i.e. it applies to either an entire + partition, or to all units in a compilation, or to a single unit, + depending on how it is used. UNIT_NAME is mapped to + FILE_NAME_LITERAL. The identifier for the second argument is + required, and indicates whether this is the file name for the spec + or for the body. + + Another form of the `Source_File_Name' pragma allows the + specification of patterns defining alternative file naming schemes + to apply to all files. + + pragma Source_File_Name + (Spec_File_Name => STRING_LITERAL + [,Casing => CASING_SPEC] + [,Dot_Replacement => STRING_LITERAL]); + + pragma Source_File_Name + (Body_File_Name => STRING_LITERAL + [,Casing => CASING_SPEC] + [,Dot_Replacement => STRING_LITERAL]); + + pragma Source_File_Name + (Subunit_File_Name => STRING_LITERAL + [,Casing => CASING_SPEC] + [,Dot_Replacement => STRING_LITERAL]); + + CASING_SPEC ::= Lowercase | Uppercase | Mixedcase + + The first argument is a pattern that contains a single asterisk + indicating the point at which the unit name is to be inserted in + the pattern string to form the file name. The second argument is + optional. If present it specifies the casing of the unit name in + the resulting file name string. The default is lower case. + Finally the third argument allows for systematic replacement of + any dots in the unit name by the specified string literal. + + For more details on the use of the `Source_File_Name' pragma, see + the sections "Using Other File Names" and "Alternative File Naming + Schemes" in the `GNAT User's Guide'. + + `pragma Source_Reference' + Syntax: + + pragma Source_Reference (INTEGER_LITERAL, + STRING_LITERAL); + + This pragma must appear as the first line of a source file. + INTEGER_LITERAL is the logical line number of the line following + the pragma line (for use in error messages and debugging + information). STRING_LITERAL is a static string constant that + specifies the file name to be used in error messages and debugging + information. This is most notably used for the output of + `gnatchop' with the `-r' switch, to make sure that the original + unchopped source file is the one referred to. + + The second argument must be a string literal, it cannot be a static + string expression other than a string literal. This is because + its value is needed for error messages issued by all phases of the + compiler. + + `pragma Stream_Convert' + Syntax: + + pragma Stream_Convert ( + [Entity =>] type_LOCAL_NAME, + [Read =>] function_NAME, + [Write =>] function NAME); + + This pragma provides an efficient way of providing stream + functions for types defined in packages. Not only is it simpler + to use than declaring the necessary functions with attribute + representation clauses, but more significantly, it allows the + declaration to made in such a way that the stream packages are not + loaded unless they are needed. The use of the Stream_Convert + pragma adds no overhead at all, unless the stream attributes are + actually used on the designated type. + + The first argument specifies the type for which stream functions + are provided. The second parameter provides a function used to + read values of this type. It must name a function whose argument + type may be any subtype, and whose returned type must be the type + given as the first argument to the pragma. + + The meaning of the READ parameter is that if a stream attribute + directly or indirectly specifies reading of the type given as the + first parameter, then a value of the type given as the argument to + the Read function is read from the stream, and then the Read + function is used to convert this to the required target type. + + Similarly the WRITE parameter specifies how to treat write + attributes that directly or indirectly apply to the type given as + the first parameter. It must have an input parameter of the type + specified by the first parameter, and the return type must be the + same as the input type of the Read function. The effect is to + first call the Write function to convert to the given stream type, + and then write the result type to the stream. + + The Read and Write functions must not be overloaded subprograms. + If necessary renamings can be supplied to meet this requirement. + The usage of this attribute is best illustrated by a simple + example, taken from the GNAT implementation of package + Ada.Strings.Unbounded: + + function To_Unbounded (S : String) + return Unbounded_String + renames To_Unbounded_String; + + pragma Stream_Convert + (Unbounded_String, To_Unbounded, To_String); + + The specifications of the referenced functions, as given in the + Ada 95 Reference Manual are: + + function To_Unbounded_String (Source : String) + return Unbounded_String; + + function To_String (Source : Unbounded_String) + return String; + + The effect is that if the value of an unbounded string is written + to a stream, then the representation of the item in the stream is + in the same format used for `Standard.String', and this same + representation is expected when a value of this type is read from + the stream. + + `pragma Style_Checks' + Syntax: + + pragma Style_Checks (string_LITERAL | ALL_CHECKS | + On | Off [, LOCAL_NAME]); + + This pragma is used in conjunction with compiler switches to + control the built in style checking provided by GNAT. The + compiler switches, if set provide an initial setting for the + switches, and this pragma may be used to modify these settings, or + the settings may be provided entirely by the use of the pragma. + This pragma can be used anywhere that a pragma is legal, including + use as a configuration pragma (including use in the `gnat.adc' + file). + + The form with a string literal specifies which style options are + to be activated. These are additive, so they apply in addition to + any previously set style check options. The codes for the options + are the same as those used in the `-gnaty' switch to `gcc' or + `gnatmake'. For example the following two methods can be used to + enable layout checking: + + pragma Style_Checks ("l"); + gcc -c -gnatyl ... + + The form ALL_CHECKS activates all standard checks (its use is + equivalent to the use of the `gnaty' switch with no options. See + GNAT User's Guide for details. + + The forms with `Off' and `On' can be used to temporarily disable + style checks as shown in the following example: + + pragma Style_Checks ("k"); -- requires keywords in lower case + pragma Style_Checks (Off); -- turn off style checks + NULL; -- this will not generate an error message + pragma Style_Checks (On); -- turn style checks back on + NULL; -- this will generate an error message + + Finally the two argument form is allowed only if the first + argument is `On' or `Off'. The effect is to turn of semantic + style checks for the specified entity, as shown in the following + example: + + pragma Style_Checks ("r"); -- require consistency of identifier casing + Arg : Integer; + Rf1 : Integer := ARG; -- incorrect, wrong case + pragma Style_Checks (Off, Arg); + Rf2 : Integer := ARG; -- OK, no error + + `pragma Subtitle' + Syntax: + + pragma Subtitle ([Subtitle =>] STRING_LITERAL); + + This pragma is recognized for compatibility with other Ada + compilers but is ignored by GNAT. + + `pragma Suppress_All' + Syntax: + + pragma Suppress_All; + + This pragma can only appear immediately following a compilation + unit. The effect is to apply `Suppress (All_Checks)' to the unit + which it follows. This pragma is implemented for compatibility + with DEC Ada 83 usage. The use of pragma `Suppress (All_Checks)' + as a normal configuration pragma is the preferred usage in GNAT. + + `pragma Suppress_Initialization' + Syntax: + + pragma Suppress_Initialization ([Entity =>] type_Name); + + This pragma suppresses any implicit or explicit initialization + associated with the given type name for all variables of this type. + + `pragma Task_Info' + Syntax + + pragma Task_Info (EXPRESSION); + + This pragma appears within a task definition (like pragma + `Priority') and applies to the task in which it appears. The + argument must be of type `System.Task_Info.Task_Info_Type'. The + `Task_Info' pragma provides system dependent control over aspect + of tasking implementation, for example, the ability to map tasks + to specific processors. For details on the facilities available + for the version of GNAT that you are using, see the documentation + in the specification of package System.Task_Info in the runtime + library. + + `pragma Task_Name' + Syntax + + pragma Task_Name (string_EXPRESSION); + + This pragma appears within a task definition (like pragma + `Priority') and applies to the task in which it appears. The + argument must be of type String, and provides a name to be used for + the task instance when the task is created. Note that this + expression is not required to be static, and in particular, it can + contain references to task discriminants. This facility can be + used to provide different names for different tasks as they are + created, as illustrated in the example below. + + The task name is recorded internally in the run-time structures + and is accessible to tools like the debugger. In addition the + routine `Ada.Task_Identification.Image' will return this string, + with a unique task address appended. + + -- Example of the use of pragma Task_Name + + with Ada.Task_Identification; + use Ada.Task_Identification; + with Text_IO; use Text_IO; + procedure t3 is + + type Astring is access String; + + task type Task_Typ (Name : access String) is + pragma Task_Name (Name.all); + end Task_Typ; + + task body Task_Typ is + Nam : constant String := Image (Current_Task); + begin + Put_Line ("-->" & Nam (1 .. 14) & "<--"); + end Task_Typ; + + type Ptr_Task is access Task_Typ; + Task_Var : Ptr_Task; + + begin + Task_Var := + new Task_Typ (new String'("This is task 1")); + Task_Var := + new Task_Typ (new String'("This is task 2")); + end; + + `pragma Task_Storage' + Syntax: + + pragma Task_Storage + [Task_Type =>] LOCAL_NAME, + [Top_Guard =>] static_integer_EXPRESSION); + + This pragma specifies the length of the guard area for tasks. The + guard area is an additional storage area allocated to a task. A + value of zero means that either no guard area is created or a + minimal guard area is created, depending on the target. This + pragma can appear anywhere a `Storage_Size' attribute definition + clause is allowed for a task type. + + `pragma Time_Slice' + Syntax: + + pragma Time_Slice (static_duration_EXPRESSION); + + For implementations of GNAT on operating systems where it is + possible to supply a time slice value, this pragma may be used for + this purpose. It is ignored if it is used in a system that does + not allow this control, or if it appears in other than the main + program unit. Note that the effect of this pragma is identical to + the effect of the DEC Ada 83 pragma of the same name when + operating under OpenVMS systems. + + `pragma Title' + Syntax: + + pragma Title (TITLING_OPTION [, TITLING OPTION]); + + TITLING_OPTION ::= + [Title =>] STRING_LITERAL, + | [Subtitle =>] STRING_LITERAL + + Syntax checked but otherwise ignored by GNAT. This is a listing + control pragma used in DEC Ada 83 implementations to provide a + title and/or subtitle for the program listing. The program + listing generated by GNAT does not have titles or subtitles. + + Unlike other pragmas, the full flexibility of named notation is + allowed for this pragma, i.e. the parameters may be given in any + order if named notation is used, and named and positional notation + can be mixed following the normal rules for procedure calls in Ada. + + `pragma Unchecked_Union' + Syntax: + + pragma Unchecked_Union (first_subtype_LOCAL_NAME) + + This pragma is used to declare that the specified type should be + represented in a manner equivalent to a C union type, and is + intended only for use in interfacing with C code that uses union + types. In Ada terms, the named type must obey the following rules: + + * It is a non-tagged non-limited record type. + + * It has a single discrete discriminant with a default value. + + * The component list consists of a single variant part. + + * Each variant has a component list with a single component. + + * No nested variants are allowed. + + * No component has an explicit default value. + + * No component has a non-static constraint. + + In addition, given a type that meets the above requirements, the + following restrictions apply to its use throughout the program: + + * The discriminant name can be mentioned only in an aggregate. + + * No subtypes may be created of this type. + + * The type may not be constrained by giving a discriminant + value. + + * The type cannot be passed as the actual for a generic formal + with a discriminant. + + Equality and inequality operations on `unchecked_unions' are not + available, since there is no discriminant to compare and the + compiler does not even know how many bits to compare. It is + implementation dependent whether this is detected at compile time + as an illegality or whether it is undetected and considered to be + an erroneous construct. In GNAT, a direct comparison is illegal, + but GNAT does not attempt to catch the composite case (where two + composites are compared that contain an unchecked union + component), so such comparisons are simply considered erroneous. + + The layout of the resulting type corresponds exactly to a C union, + where each branch of the union corresponds to a single variant in + the Ada record. The semantics of the Ada program is not changed + in any way by the pragma, i.e. provided the above restrictions are + followed, and no erroneous incorrect references to fields or + erroneous comparisons occur, the semantics is exactly as described + by the Ada reference manual. Pragma `Suppress + (Discriminant_Check)' applies implicitly to the type and the + default convention is C + + `pragma Unimplemented_Unit' + Syntax: + + pragma Unimplemented_Unit; + + If this pragma occurs in a unit that is processed by the compiler, + GNAT aborts with the message `XXX not implemented', where XXX is + the name of the current compilation unit. This pragma is intended + to allow the compiler to handle unimplemented library units in a + clean manner. + + The abort only happens if code is being generated. Thus you can + use specs of unimplemented packages in syntax or semantic checking + mode. + + `pragma Unreferenced' + Syntax: + + pragma Unreferenced (local_Name {, local_Name}); + + This pragma signals that the entities whose names are listed are + deliberately not referenced. This suppresses warnings about the + entities being unreferenced, and in addition a warning will be + generated if one of these entities is in fact referenced. + + This is particularly useful for clearly signalling that a + particular parameter is not referenced in some particular + subprogram implementation and that this is deliberate. It can also + be useful in the case of objects declared only for their + initialization or finalization side effects. + + If `local_Name' identifies more than one matching homonym in the + current scope, then the entity most recently declared is the one + to which the pragma applies. + + `pragma Unreserve_All_Interrupts' + Syntax: + + pragma Unreserve_All_Interrupts; + + Normally certain interrupts are reserved to the implementation. + Any attempt to attach an interrupt causes Program_Error to be + raised, as described in RM C.3.2(22). A typical example is the + `SIGINT' interrupt used in many systems for an `Ctrl-C' interrupt. + Normally this interrupt is reserved to the implementation, so + that `Ctrl-C' can be used to interrupt execution. + + If the pragma `Unreserve_All_Interrupts' appears anywhere in any + unit in a program, then all such interrupts are unreserved. This + allows the program to handle these interrupts, but disables their + standard functions. For example, if this pragma is used, then + pressing `Ctrl-C' will not automatically interrupt execution. + However, a program can then handle the `SIGINT' interrupt as it + chooses. + + For a full list of the interrupts handled in a specific + implementation, see the source code for the specification of + `Ada.Interrupts.Names' in file `a-intnam.ads'. This is a target + dependent file that contains the list of interrupts recognized for + a given target. The documentation in this file also specifies + what interrupts are affected by the use of the + `Unreserve_All_Interrupts' pragma. + + `pragma Unsuppress' + Syntax: + + pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); + + This pragma undoes the effect of a previous pragma `Suppress'. If + there is no corresponding pragma `Suppress' in effect, it has no + effect. The range of the effect is the same as for pragma + `Suppress'. The meaning of the arguments is identical to that used + in pragma `Suppress'. + + One important application is to ensure that checks are on in cases + where code depends on the checks for its correct functioning, so + that the code will compile correctly even if the compiler switches + are set to suppress checks. + + `pragma Use_VADS_Size' + Syntax: + + pragma Use_VADS_Size; + + This is a configuration pragma. In a unit to which it applies, + any use of the 'Size attribute is automatically interpreted as a + use of the 'VADS_Size attribute. Note that this may result in + incorrect semantic processing of valid Ada 95 programs. This is + intended to aid in the handling of legacy code which depends on + the interpretation of Size as implemented in the VADS compiler. + See description of the VADS_Size attribute for further details. + + `pragma Validity_Checks' + Syntax: + + pragma Validity_Checks (string_LITERAL | ALL_CHECKS | On | Off); + + This pragma is used in conjunction with compiler switches to + control the built in validity checking provided by GNAT. The + compiler switches, if set provide an initial setting for the + switches, and this pragma may be used to modify these settings, or + the settings may be provided entirely by the use of the pragma. + This pragma can be used anywhere that a pragma is legal, including + use as a configuration pragma (including use in the `gnat.adc' + file). + + The form with a string literal specifies which validity options + are to be activated. The validity checks are first set to include + only the default reference manual settings, and then a string of + letters in the string specifies the exact set of options required. + The form of this string is exactly as described for the `-gnatVx' + compiler switch (see the GNAT users guide for details). For + example the following two methods can be used to enable validity + checking for mode `in' and `in out' subprogram parameters: + + pragma Validity_Checks ("im"); + gcc -c -gnatVim ... + + The form ALL_CHECKS activates all standard checks (its use is + equivalent to the use of the `gnatva' switch. + + The forms with `Off' and `On' can be used to temporarily disable + validity checks as shown in the following example: + + pragma Validity_Checks ("c"); -- validity checks for copies + pragma Validity_Checks (Off); -- turn off validity checks + A := B; -- B will not be validity checked + pragma Validity_Checks (On); -- turn validity checks back on + A := C; -- C will be validity checked + + `pragma Volatile' + Syntax: + + pragma Volatile (local_NAME) + + This pragma is defined by the Ada 95 Reference Manual, and the GNAT + implementation is fully conformant with this definition. The + reason it is mentioned in this section is that a pragma of the + same name was supplied in some Ada 83 compilers, including DEC Ada + 83. The Ada 95 implementation of pragma Volatile is upwards + compatible with the implementation in Dec Ada 83. + + `pragma Warnings' + Syntax: + + pragma Warnings (On | Off [, LOCAL_NAME]); + + Normally warnings are enabled, with the output being controlled by + the command line switch. Warnings (`Off') turns off generation of + warnings until a Warnings (`On') is encountered or the end of the + current unit. If generation of warnings is turned off using this + pragma, then no warning messages are output, regardless of the + setting of the command line switches. + + The form with a single argument is a configuration pragma. + + If the LOCAL_NAME parameter is present, warnings are suppressed for + the specified entity. This suppression is effective from the + point where it occurs till the end of the extended scope of the + variable (similar to the scope of `Suppress'). + + `pragma Weak_External' + Syntax: + + pragma Weak_External ([Entity =>] LOCAL_NAME); + + This pragma specifies that the given entity should be marked as a + weak external (one that does not have to be resolved) for the + linker. For further details, consult the GCC manual. + +  + File: gnat_rm.info, Node: Implementation Defined Attributes, Next: Implementation Advice, Prev: Implementation Defined Pragmas, Up: Top + + Implementation Defined Attributes + ********************************* + + Ada 95 defines (throughout the Ada 95 reference manual, summarized + in annex K), a set of attributes that provide useful additional + functionality in all areas of the language. These language defined + attributes are implemented in GNAT and work as described in the Ada 95 + Reference Manual. + + In addition, Ada 95 allows implementations to define additional + attributes whose meaning is defined by the implementation. GNAT + provides a number of these implementation-dependent attributes which + can be used to extend and enhance the functionality of the compiler. + This section of the GNAT reference manual describes these additional + attributes. + + Note that any program using these attributes may not be portable to + other compilers (although GNAT implements this set of attributes on all + platforms). Therefore if portability to other compilers is an important + consideration, you should minimize the use of these attributes. + + `Abort_Signal' + `Standard'Abort_Signal' (`Standard' is the only allowed prefix) + provides the entity for the special exception used to signal task + abort or asynchronous transfer of control. Normally this attribute + should only be used in the tasking runtime (it is highly peculiar, + and completely outside the normal semantics of Ada, for a user + program to intercept the abort exception). + + `Address_Size' + `Standard'Address_Size' (`Standard' is the only allowed prefix) is + a static constant giving the number of bits in an `Address'. It + is used primarily for constructing the definition of `Memory_Size' + in package `Standard', but may be freely used in user programs and + has the advantage of being static, while a direct reference to + System.Address'Size is non-static because Address is a private + type. + + `Asm_Input' + The `Asm_Input' attribute denotes a function that takes two + parameters. The first is a string, the second is an expression of + the type designated by the prefix. The first (string) argument is + required to be a static expression, and is the constraint for the + parameter, (e.g. what kind of register is required). The second + argument is the value to be used as the input argument. The + possible values for the constant are the same as those used in the + RTL, and are dependent on the configuration file used to built the + GCC back end. *Note Machine Code Insertions:: + + `Asm_Output' + The `Asm_Output' attribute denotes a function that takes two + parameters. The first is a string, the second is the name of a + variable of the type designated by the attribute prefix. The + first (string) argument is required to be a static expression and + designates the constraint for the parameter (e.g. what kind of + register is required). The second argument is the variable to be + updated with the result. The possible values for constraint are + the same as those used in the RTL, and are dependent on the + configuration file used to build the GCC back end. If there are + no output operands, then this argument may either be omitted, or + explicitly given as `No_Output_Operands'. *Note Machine Code + Insertions:: + + `AST_Entry' + This attribute is implemented only in OpenVMS versions of GNAT. + Applied to the name of an entry, it yields a value of the + predefined type AST_Handler (declared in the predefined package + System, as extended by the use of pragma `Extend_System + (Aux_DEC)'). This value enables the given entry to be called when + an AST occurs. For further details, refer to the `DEC Ada + Language Reference Manual', section 9.12a. + + `Bit' + `OBJ'Bit', where OBJ is any object, yields the bit offset within + the storage unit (byte) that contains the first bit of storage + allocated for the object. The value of this attribute is of the + type `Universal_Integer', and is always a non-negative number not + exceeding the value of `System.Storage_Unit'. + + For an object that is a variable or a constant allocated in a + register, the value is zero. (The use of this attribute does not + force the allocation of a variable to memory). + + For an object that is a formal parameter, this attribute applies + to either the matching actual parameter or to a copy of the + matching actual parameter. + + For an access object the value is zero. Note that `OBJ.all'Bit' + is subject to an `Access_Check' for the designated object. + Similarly for a record component `X.C'Bit' is subject to a + discriminant check and `X(I).Bit' and `X(I1..I2)'Bit' are subject + to index checks. + + This attribute is designed to be compatible with the DEC Ada 83 + definition and implementation of the `Bit' attribute. + + `Bit_Position' + `R.C'Bit', where R is a record object and C is one of the fields + of the record type, yields the bit offset within the record + contains the first bit of storage allocated for the object. The + value of this attribute is of the type `Universal_Integer'. The + value depends only on the field C and is independent of the + alignment of the containing record R. + + `Code_Address' + The `'Address' attribute may be applied to subprograms in Ada 95, + but the intended effect from the Ada 95 reference manual seems to + be to provide an address value which can be used to call the + subprogram by means of an address clause as in the following + example: + + procedure K is ... + + procedure L; + for L'Address use K'Address; + pragma Import (Ada, L); + + A call to `L' is then expected to result in a call to `K'. In Ada + 83, where there were no access-to-subprogram values, this was a + common work around for getting the effect of an indirect call. + GNAT implements the above use of `Address' and the technique + illustrated by the example code works correctly. + + However, for some purposes, it is useful to have the address of + the start of the generated code for the subprogram. On some + architectures, this is not necessarily the same as the `Address' + value described above. For example, the `Address' value may + reference a subprogram descriptor rather than the subprogram + itself. + + The `'Code_Address' attribute, which can only be applied to + subprogram entities, always returns the address of the start of the + generated code of the specified subprogram, which may or may not be + the same value as is returned by the corresponding `'Address' + attribute. + + `Default_Bit_Order' + `Standard'Default_Bit_Order' (`Standard' is the only permissible + prefix), provides the value `System.Default_Bit_Order' as a `Pos' + value (0 for `High_Order_First', 1 for `Low_Order_First'). This + is used to construct the definition of `Default_Bit_Order' in + package `System'. + + `Elaborated' + The prefix of the `'Elaborated' attribute must be a unit name. The + value is a Boolean which indicates whether or not the given unit + has been elaborated. This attribute is primarily intended for + internal use by the generated code for dynamic elaboration + checking, but it can also be used in user programs. The value + will always be True once elaboration of all units has been + completed. + + `Elab_Body' + This attribute can only be applied to a program unit name. It + returns the entity for the corresponding elaboration procedure for + elaborating the body of the referenced unit. This is used in the + main generated elaboration procedure by the binder and is not + normally used in any other context. However, there may be + specialized situations in which it is useful to be able to call + this elaboration procedure from Ada code, e.g. if it is necessary + to do selective re-elaboration to fix some error. + + `Elab_Spec' + This attribute can only be applied to a program unit name. It + returns the entity for the corresponding elaboration procedure for + elaborating the specification of the referenced unit. This is + used in the main generated elaboration procedure by the binder and + is not normally used in any other context. However, there may be + specialized situations in which it is useful to be able to call + this elaboration procedure from Ada code, e.g. if it is necessary + to do selective re-elaboration to fix some error. + + `Emax' + The `Emax' attribute is provided for compatibility with Ada 83. + See the Ada 83 reference manual for an exact description of the + semantics of this attribute. + + `Enum_Rep' + For every enumeration subtype S, `S'Enum_Rep' denotes a function + with the following specification: + + function S'Enum_Rep (Arg : S'Base) + return Universal_Integer; + + It is also allowable to apply `Enum_Rep' directly to an object of + an enumeration type or to a non-overloaded enumeration literal. + In this case `S'Enum_Rep' is equivalent to `TYP'Enum_Rep(S)' where + TYP is the type of the enumeration literal or object. + + The function returns the representation value for the given + enumeration value. This will be equal to value of the `Pos' + attribute in the absence of an enumeration representation clause. + This is a static attribute (i.e. the result is static if the + argument is static). + + `S'Enum_Rep' can also be used with integer types and objects, in + which case it simply returns the integer value. The reason for + this is to allow it to be used for `(<>)' discrete formal + arguments in a generic unit that can be instantiated with either + enumeration types or integer types. Note that if `Enum_Rep' is + used on a modular type whose upper bound exceeds the upper bound + of the largest signed integer type, and the argument is a + variable, so that the universal integer calculation is done at + run-time, then the call to `Enum_Rep' may raise `Constraint_Error'. + + `Epsilon' + The `Epsilon' attribute is provided for compatibility with Ada 83. + See the Ada 83 reference manual for an exact description of the + semantics of this attribute. + + `Fixed_Value' + For every fixed-point type S, `S'Fixed_Value' denotes a function + with the following specification: + + function S'Fixed_Value (Arg : Universal_Integer) + return S; + + The value returned is the fixed-point value V such that + + V = Arg * S'Small + + The effect is thus equivalent to first converting the argument to + the integer type used to represent S, and then doing an unchecked + conversion to the fixed-point type. This attribute is primarily + intended for use in implementation of the input-output functions + for fixed-point values. + + `Has_Discriminants' + The prefix of the `Has_Discriminants' attribute is a type. The + result is a Boolean value which is True if the type has + discriminants, and False otherwise. The intended use of this + attribute is in conjunction with generic definitions. If the + attribute is applied to a generic private type, it indicates + whether or not the corresponding actual type has discriminants. + + `Img' + The `Img' attribute differs from `Image' in that it may be applied + to objects as well as types, in which case it gives the `Image' + for the subtype of the object. This is convenient for debugging: + + Put_Line ("X = " & X'Img); + + has the same meaning as the more verbose: + + Put_Line ("X = " & TYPE'Image (X)); + + where TYPE is the subtype of the object X. + + `Integer_Value' + For every integer type S, `S'Integer_Value' denotes a function + with the following specification: + + function S'Integer_Value (Arg : Universal_Fixed) + return S; + + The value returned is the integer value V, such that + + Arg = V * TYPE'Small + + The effect is thus equivalent to first doing an unchecked convert + from the fixed-point type to its corresponding implementation + type, and then converting the result to the target integer type. + This attribute is primarily intended for use in implementation of + the standard input-output functions for fixed-point values. + + `Large' + The `Large' attribute is provided for compatibility with Ada 83. + See the Ada 83 reference manual for an exact description of the + semantics of this attribute. + + `Machine_Size' + This attribute is identical to the `Object_Size' attribute. It is + provided for compatibility with the DEC Ada 83 attribute of this + name. + + `Mantissa' + The `Mantissa' attribute is provided for compatibility with Ada + 83. See the Ada 83 reference manual for an exact description of + the semantics of this attribute. + + `Max_Interrupt_Priority' + `Standard'Max_Interrupt_Priority' (`Standard' is the only + permissible prefix), provides the value + `System.Max_Interrupt_Priority' and is intended primarily for + constructing this definition in package `System'. + + `Max_Priority' + `Standard'Max_Priority' (`Standard' is the only permissible + prefix) provides the value `System.Max_Priority' and is intended + primarily for constructing this definition in package `System'. + + `Maximum_Alignment' + `Standard'Maximum_Alignment' (`Standard' is the only permissible + prefix) provides the maximum useful alignment value for the + target. This is a static value that can be used to specify the + alignment for an object, guaranteeing that it is properly aligned + in all cases. This is useful when an external object is imported + and its alignment requirements are unknown. + + `Mechanism_Code' + `FUNCTION'Mechanism_Code' yields an integer code for the mechanism + used for the result of function, and `SUBPROGRAM'Mechanism_Code + (N)' yields the mechanism used for formal parameter number N (a + static integer value with 1 meaning the first parameter) of + SUBPROGRAM. The code returned is: + + 1 + by copy (value) + + 2 + by reference + + 3 + by descriptor (default descriptor class) + + 4 + by descriptor (UBS: unaligned bit string) + + 5 + by descriptor (UBSB: aligned bit string with arbitrary bounds) + + 6 + by descriptor (UBA: unaligned bit array) + + 7 + by descriptor (S: string, also scalar access type parameter) + + 8 + by descriptor (SB: string with arbitrary bounds) + + 9 + by descriptor (A: contiguous array) + + 10 + by descriptor (NCA: non-contiguous array) + + Values from 3 through 10 are only relevant to Digital OpenVMS + implementations. + + `Null_Parameter' + A reference `T'Null_Parameter' denotes an imaginary object of type + or subtype T allocated at machine address zero. The attribute is + allowed only as the default expression of a formal parameter, or as + an actual expression of a subprogram call. In either case, the + subprogram must be imported. + + The identity of the object is represented by the address zero in + the argument list, independent of the passing mechanism (explicit + or default). + + This capability is needed to specify that a zero address should be + passed for a record or other composite object passed by reference. + There is no way of indicating this without the `Null_Parameter' + attribute. + + `Object_Size' + The size of an object is not necessarily the same as the size of + the type of an object. This is because by default object sizes + are increased to be a multiple of the alignment of the object. + For example, `Natural'Size' is 31, but by default objects of type + `Natural' will have a size of 32 bits. Similarly, a record + containing an integer and a character: + + type Rec is record + I : Integer; + C : Character; + end record; + + will have a size of 40 (that is `Rec'Size' will be 40. The + alignment will be 4, because of the integer field, and so the + default size of record objects for this type will be 64 (8 bytes). + + The `TYPE'Object_Size' attribute has been added to GNAT to allow + the default object size of a type to be easily determined. For + example, `Natural'Object_Size' is 32, and `Rec'Object_Size' (for + the record type in the above example) will be 64. Note also that, + unlike the situation with the `Size' attribute as defined in the + Ada RM, the `Object_Size' attribute can be specified individually + for different subtypes. For example: + + type R is new Integer; + subtype R1 is R range 1 .. 10; + subtype R2 is R range 1 .. 10; + for R2'Object_Size use 8; + + In this example, `R'Object_Size' and `R1'Object_Size' are both 32 + since the default object size for a subtype is the same as the + object size for the parent subtype. This means that objects of + type `R' or `R1' will by default be 32 bits (four bytes). But + objects of type `R2' will be only 8 bits (one byte), since + `R2'Object_Size' has been set to 8. + + `Passed_By_Reference' + `TYPE'Passed_By_Reference' for any subtype TYPE returns a value of + type `Boolean' value that is `True' if the type is normally passed + by reference and `False' if the type is normally passed by copy in + calls. For scalar types, the result is always `False' and is + static. For non-scalar types, the result is non-static. + + `Range_Length' + `TYPE'Range_Length' for any discrete type TYPE yields the number + of values represented by the subtype (zero for a null range). The + result is static for static subtypes. `Range_Length' applied to + the index subtype of a one dimensional array always gives the same + result as `Range' applied to the array itself. + + `Safe_Emax' + The `Safe_Emax' attribute is provided for compatibility with Ada + 83. See the Ada 83 reference manual for an exact description of + the semantics of this attribute. + + `Safe_Large' + The `Safe_Large' attribute is provided for compatibility with Ada + 83. See the Ada 83 reference manual for an exact description of + the semantics of this attribute. + + `Safe_Large' + The `Safe_Large' attribute is provided for compatibility with Ada + 83. See the Ada 83 reference manual for an exact description of + the semantics of this attribute. + + `Small' + The `Small' attribute is defined in Ada 95 only for fixed-point + types. GNAT also allows this attribute to be applied to + floating-point types for compatibility with Ada 83. See the Ada + 83 reference manual for an exact description of the semantics of + this attribute when applied to floating-point types. + + `Storage_Unit' + `Standard'Storage_Unit' (`Standard' is the only permissible + prefix) provides the value `System.Storage_Unit' and is intended + primarily for constructing this definition in package `System'. + + `Tick' + `Standard'Tick' (`Standard' is the only permissible prefix) + provides the value of `System.Tick' and is intended primarily for + constructing this definition in package `System'. + + `To_Address' + The `System'To_Address' (`System' is the only permissible prefix) + denotes a function identical to + `System.Storage_Elements.To_Address' except that it is a static + attribute. This means that if its argument is a static + expression, then the result of the attribute is a static + expression. The result is that such an expression can be used in + contexts (e.g. preelaborable packages) which require a static + expression and where the function call could not be used (since + the function call is always non-static, even if its argument is + static). + + `Type_Class' + `TYPE'Type_Class' for any type or subtype TYPE yields the value of + the type class for the full type of TYPE. If TYPE is a generic + formal type, the value is the value for the corresponding actual + subtype. The value of this attribute is of type + `System.Aux_DEC.Type_Class', which has the following definition: + + type Type_Class is + (Type_Class_Enumeration, + Type_Class_Integer, + Type_Class_Fixed_Point, + Type_Class_Floating_Point, + Type_Class_Array, + Type_Class_Record, + Type_Class_Access, + Type_Class_Task, + Type_Class_Address); + + Protected types yield the value `Type_Class_Task', which thus + applies to all concurrent types. This attribute is designed to be + compatible with the DEC Ada 83 attribute of the same name. + + `UET_Address' + The `UET_Address' attribute can only be used for a prefix which + denotes a library package. It yields the address of the unit + exception table when zero cost exception handling is used. This + attribute is intended only for use within the GNAT implementation. + See the unit `Ada.Exceptions' in files `a-except.ads' and + `a-except.adb' for details on how this attribute is used in the + implementation. + + `Universal_Literal_String' + The prefix of `Universal_Literal_String' must be a named number. + The static result is the string consisting of the characters of + the number as defined in the original source. This allows the user + program to access the actual text of named numbers without + intermediate conversions and without the need to enclose the + strings in quotes (which would preclude their use as numbers). + This is used internally for the construction of values of the + floating-point attributes from the file `ttypef.ads', but may also + be used by user programs. + + `Unrestricted_Access' + The `Unrestricted_Access' attribute is similar to `Access' except + that all accessibility and aliased view checks are omitted. This + is a user-beware attribute. It is similar to `Address', for which + it is a desirable replacement where the value desired is an access + type. In other words, its effect is identical to first applying + the `Address' attribute and then doing an unchecked conversion to + a desired access type. In GNAT, but not necessarily in other + implementations, the use of static chains for inner level + subprograms means that `Unrestricted_Access' applied to a + subprogram yields a value that can be called as long as the + subprogram is in scope (normal Ada 95 accessibility rules restrict + this usage). + + `VADS_Size' + The `'VADS_Size' attribute is intended to make it easier to port + legacy code which relies on the semantics of `'Size' as implemented + by the VADS Ada 83 compiler. GNAT makes a best effort at + duplicating the same semantic interpretation. In particular, + `'VADS_Size' applied to a predefined or other primitive type with + no Size clause yields the Object_Size (for example, `Natural'Size' + is 32 rather than 31 on typical machines). In addition + `'VADS_Size' applied to an object gives the result that would be + obtained by applying the attribute to the corresponding type. + + `Value_Size' + `TYPE'Value_Size' is the number of bits required to represent a + value of the given subtype. It is the same as `TYPE'Size', but, + unlike `Size', may be set for non-first subtypes. + + `Wchar_T_Size' + `Standard'Wchar_T_Size' (`Standard' is the only permissible + prefix) provides the size in bits of the C `wchar_t' type + primarily for constructing the definition of this type in package + `Interfaces.C'. + + `Word_Size' + `Standard'Word_Size' (`Standard' is the only permissible prefix) + provides the value `System.Word_Size' and is intended primarily + for constructing this definition in package `System'. + +  + File: gnat_rm.info, Node: Implementation Advice, Next: Implementation Defined Characteristics, Prev: Implementation Defined Attributes, Up: Top + + Implementation Advice + ********************* + + The main text of the Ada 95 Reference Manual describes the required + behavior of all Ada 95 compilers, and the GNAT compiler conforms to + these requirements. + + In addition, there are sections throughout the Ada 95 reference + manual headed by the phrase "implementation advice". These sections + are not normative, i.e. they do not specify requirements that all + compilers must follow. Rather they provide advice on generally + desirable behavior. You may wonder why they are not requirements. The + most typical answer is that they describe behavior that seems generally + desirable, but cannot be provided on all systems, or which may be + undesirable on some systems. + + As far as practical, GNAT follows the implementation advice sections + in the Ada 95 Reference Manual. This chapter contains a table giving + the reference manual section number, paragraph number and several + keywords for each advice. Each entry consists of the text of the + advice followed by the GNAT interpretation of this advice. Most often, + this simply says "followed", which means that GNAT follows the advice. + However, in a number of cases, GNAT deliberately deviates from this + advice, in which case the text describes what GNAT does and why. + + *1.1.3(20): Error Detection* + + If an implementation detects the use of an unsupported Specialized + Needs Annex feature at run time, it should raise `Program_Error' if + feasible. + Not relevant. All specialized needs annex features are either + supported, or diagnosed at compile time. + + *1.1.3(31): Child Units* + + If an implementation wishes to provide implementation-defined + extensions to the functionality of a language-defined library + unit, it should normally do so by adding children to the library + unit. + Followed. + + *1.1.5(12): Bounded Errors* + + If an implementation detects a bounded error or erroneous + execution, it should raise `Program_Error'. + Followed in all cases in which the implementation detects a bounded + error or erroneous execution. Not all such situations are + detected at runtime. + + *2.8(16): Pragmas* + + Normally, implementation-defined pragmas should have no semantic + effect for error-free programs; that is, if the + implementation-defined pragmas are removed from a working program, + the program should still be legal, and should still have the same + semantics. + The following implementation defined pragmas are exceptions to this + rule: + + `Abort_Defer' + Affects semantics + + `Ada_83' + Affects legality + + `Assert' + Affects semantics + + `CPP_Class' + Affects semantics + + `CPP_Constructor' + Affects semantics + + `CPP_Virtual' + Affects semantics + + `CPP_Vtable' + Affects semantics + + `Debug' + Affects semantics + + `Interface_Name' + Affects semantics + + `Machine_Attribute' + Affects semantics + + `Unimplemented_Unit' + Affects legality + + `Unchecked_Union' + Affects semantics + + In each of the above cases, it is essential to the purpose of the + pragma that this advice not be followed. For details see the + separate section on implementation defined pragmas. + + *2.8(17-19): Pragmas* + + Normally, an implementation should not define pragmas that can + make an illegal program legal, except as follows: + + + A pragma used to complete a declaration, such as a pragma `Import'; + + + A pragma used to configure the environment by adding, removing, or + replacing `library_items'. + See response to paragraph 16 of this same section. + + *3.5.2(5): Alternative Character Sets* + + If an implementation supports a mode with alternative + interpretations for `Character' and `Wide_Character', the set of + graphic characters of `Character' should nevertheless remain a + proper subset of the set of graphic characters of + `Wide_Character'. Any character set "localizations" should be + reflected in the results of the subprograms defined in the + language-defined package `Characters.Handling' (see A.3) available + in such a mode. In a mode with an alternative interpretation of + `Character', the implementation should also support a + corresponding change in what is a legal `identifier_letter'. + Not all wide character modes follow this advice, in particular the + JIS and IEC modes reflect standard usage in Japan, and in these + encoding, the upper half of the Latin-1 set is not part of the + wide-character subset, since the most significant bit is used for + wide character encoding. However, this only applies to the + external forms. Internally there is no such restriction. + + *3.5.4(28): Integer Types* + + An implementation should support `Long_Integer' in addition to + `Integer' if the target machine supports 32-bit (or longer) + arithmetic. No other named integer subtypes are recommended for + package `Standard'. Instead, appropriate named integer subtypes + should be provided in the library package `Interfaces' (see B.2). + `Long_Integer' is supported. Other standard integer types are + supported so this advice is not fully followed. These types are + supported for convenient interface to C, and so that all hardware + types of the machine are easily available. + + *3.5.4(29): Integer Types* + + An implementation for a two's complement machine should support + modular types with a binary modulus up to `System.Max_Int*2+2'. An + implementation should support a non-binary modules up to + `Integer'Last'. + Followed. + + *3.5.5(8): Enumeration Values* + + For the evaluation of a call on `S'Pos' for an enumeration + subtype, if the value of the operand does not correspond to the + internal code for any enumeration literal of its type (perhaps due + to an un-initialized variable), then the implementation should + raise `Program_Error'. This is particularly important for + enumeration types with noncontiguous internal codes specified by an + enumeration_representation_clause. + Followed. + + *3.5.7(17): Float Types* + + An implementation should support `Long_Float' in addition to + `Float' if the target machine supports 11 or more digits of + precision. No other named floating point subtypes are recommended + for package `Standard'. Instead, appropriate named floating point + subtypes should be provided in the library package `Interfaces' + (see B.2). + `Short_Float' and `Long_Long_Float' are also provided. The former + provides improved compatibility with other implementations + supporting this type. The latter corresponds to the highest + precision floating-point type supported by the hardware. On most + machines, this will be the same as `Long_Float', but on some + machines, it will correspond to the IEEE extended form. The + notable case is all ia32 (x86) implementations, where + `Long_Long_Float' corresponds to the 80-bit extended precision + format supported in hardware on this processor. Note that the + 128-bit format on SPARC is not supported, since this is a software + rather than a hardware format. + + *3.6.2(11): Multidimensional Arrays* + + An implementation should normally represent multidimensional + arrays in row-major order, consistent with the notation used for + multidimensional array aggregates (see 4.3.3). However, if a + pragma `Convention' (`Fortran', ...) applies to a multidimensional + array type, then column-major order should be used instead (see + B.5, "Interfacing with Fortran"). + Followed. + + *9.6(30-31): Duration'Small* + + Whenever possible in an implementation, the value of + `Duration'Small' should be no greater than 100 microseconds. + Followed. (`Duration'Small' = 10**(-9)). + + + The time base for `delay_relative_statements' should be monotonic; + it need not be the same time base as used for `Calendar.Clock'. + Followed. + + *10.2.1(12): Consistent Representation* + + In an implementation, a type declared in a pre-elaborated package + should have the same representation in every elaboration of a + given version of the package, whether the elaborations occur in + distinct executions of the same program, or in executions of + distinct programs or partitions that include the given version. + Followed, except in the case of tagged types. Tagged types involve + implicit pointers to a local copy of a dispatch table, and these + pointers have representations which thus depend on a particular + elaboration of the package. It is not easy to see how it would be + possible to follow this advice without severely impacting + efficiency of execution. + + *11.4.1(19): Exception Information* + + `Exception_Message' by default and `Exception_Information' should + produce information useful for debugging. `Exception_Message' + should be short, about one line. `Exception_Information' can be + long. `Exception_Message' should not include the + `Exception_Name'. `Exception_Information' should include both the + `Exception_Name' and the `Exception_Message'. + Followed. For each exception that doesn't have a specified + `Exception_Message', the compiler generates one containing the + location of the raise statement. This location has the form + "file:line", where file is the short file name (without path + information) and line is the line number in the file. Note that + in the case of the Zero Cost Exception mechanism, these messages + become redundant with the Exception_Information that contains a + full backtrace of the calling sequence, so they are disabled. To + disable explicitly the generation of the source location message, + use the Pragma `Discard_Names'. + + *11.5(28): Suppression of Checks* + + The implementation should minimize the code executed for checks + that have been suppressed. + Followed. + + *13.1 (21-24): Representation Clauses* + + The recommended level of support for all representation items is + qualified as follows: + + + An implementation need not support representation items containing + non-static expressions, except that an implementation should + support a representation item for a given entity if each + non-static expression in the representation item is a name that + statically denotes a constant declared before the entity. + Followed. GNAT does not support non-static expressions in + representation clauses unless they are constants declared before + the entity. For example: + + X : typ; + for X'Address use To_address (16#2000#); + + will be rejected, since the To_Address expression is non-static. + Instead write: + + X_Address : constant Address : = + To_Address ((16#2000#); + X : typ; + for X'Address use X_Address; + + + An implementation need not support a specification for the `Size' + for a given composite subtype, nor the size or storage place for an + object (including a component) of a given composite subtype, + unless the constraints on the subtype and its composite + subcomponents (if any) are all static constraints. + Followed. Size Clauses are not permitted on non-static + components, as described above. + + + An aliased component, or a component whose type is by-reference, + should always be allocated at an addressable location. + Followed. + + *13.2(6-8): Packed Types* + + If a type is packed, then the implementation should try to minimize + storage allocated to objects of the type, possibly at the expense + of speed of accessing components, subject to reasonable complexity + in addressing calculations. + + + The recommended level of support pragma `Pack' is: + + For a packed record type, the components should be packed as + tightly as possible subject to the Sizes of the component + subtypes, and subject to any `record_representation_clause' that + applies to the type; the implementation may, but need not, reorder + components or cross aligned word boundaries to improve the + packing. A component whose `Size' is greater than the word size + may be allocated an integral number of words. + Followed. Tight packing of arrays is supported for all component + sizes up to 64-bits. + + + An implementation should support Address clauses for imported + subprograms. + Followed. + + *13.3(14-19): Address Clauses* + + For an array X, `X'Address' should point at the first component of + the array, and not at the array bounds. + Followed. + + + The recommended level of support for the `Address' attribute is: + + `X'Address' should produce a useful result if X is an object that + is aliased or of a by-reference type, or is an entity whose + `Address' has been specified. + Followed. A valid address will be produced even if none of those + conditions have been met. If necessary, the object is forced into + memory to ensure the address is valid. + + + An implementation should support `Address' clauses for imported + subprograms. + Followed. + + + Objects (including subcomponents) that are aliased or of a + by-reference type should be allocated on storage element + boundaries. + Followed. + + + If the `Address' of an object is specified, or it is imported or + exported, then the implementation should not perform optimizations + based on assumptions of no aliases. + Followed. + + *13.3(29-35): Alignment Clauses* + + The recommended level of support for the `Alignment' attribute for + subtypes is: + + An implementation should support specified Alignments that are + factors and multiples of the number of storage elements per word, + subject to the following: + Followed. + + + An implementation need not support specified `Alignment's for + combinations of `Size's and `Alignment's that cannot be easily + loaded and stored by available machine instructions. + Followed. + + + An implementation need not support specified `Alignment's that are + greater than the maximum `Alignment' the implementation ever + returns by default. + Followed. + + + The recommended level of support for the `Alignment' attribute for + objects is: + + Same as above, for subtypes, but in addition: + Followed. + + + For stand-alone library-level objects of statically constrained + subtypes, the implementation should support all `Alignment's + supported by the target linker. For example, page alignment is + likely to be supported for such objects, but not for subtypes. + Followed. + + *13.3(42-43): Size Clauses* + + The recommended level of support for the `Size' attribute of + objects is: + + A `Size' clause should be supported for an object if the specified + `Size' is at least as large as its subtype's `Size', and + corresponds to a size in storage elements that is a multiple of the + object's `Alignment' (if the `Alignment' is nonzero). + Followed. + + *13.3(50-56): Size Clauses* + + If the `Size' of a subtype is specified, and allows for efficient + independent addressability (see 9.10) on the target architecture, + then the `Size' of the following objects of the subtype should + equal the `Size' of the subtype: + + Aliased objects (including components). + Followed. + + + `Size' clause on a composite subtype should not affect the + internal layout of components. + Followed. + + + The recommended level of support for the `Size' attribute of + subtypes is: + + + The `Size' (if not specified) of a static discrete or fixed point + subtype should be the number of bits needed to represent each value + belonging to the subtype using an unbiased representation, leaving + space for a sign bit only if the subtype contains negative values. + If such a subtype is a first subtype, then an implementation + should support a specified `Size' for it that reflects this + representation. + Followed. + + + For a subtype implemented with levels of indirection, the `Size' + should include the size of the pointers, but not the size of what + they point at. + Followed. + + *13.3(71-73): Component Size Clauses* + + The recommended level of support for the `Component_Size' + attribute is: + + + An implementation need not support specified `Component_Sizes' + that are less than the `Size' of the component subtype. + Followed. + + + An implementation should support specified `Component_Size's that + are factors and multiples of the word size. For such + `Component_Size's, the array should contain no gaps between + components. For other `Component_Size's (if supported), the array + should contain no gaps between components when packing is also + specified; the implementation should forbid this combination in + cases where it cannot support a no-gaps representation. + Followed. + + *13.4(9-10): Enumeration Representation Clauses* + + The recommended level of support for enumeration representation + clauses is: + + An implementation need not support enumeration representation + clauses for boolean types, but should at minimum support the + internal codes in the range `System.Min_Int.System.Max_Int'. + Followed. + + *13.5.1(17-22): Record Representation Clauses* + + The recommended level of support for + `record_representation_clauses' is: + + An implementation should support storage places that can be + extracted with a load, mask, shift sequence of machine code, and + set with a load, shift, mask, store sequence, given the available + machine instructions and run-time model. + Followed. + + + A storage place should be supported if its size is equal to the + `Size' of the component subtype, and it starts and ends on a + boundary that obeys the `Alignment' of the component subtype. + Followed. + + + If the default bit ordering applies to the declaration of a given + type, then for a component whose subtype's `Size' is less than the + word size, any storage place that does not cross an aligned word + boundary should be supported. + Followed. + + + An implementation may reserve a storage place for the tag field of + a tagged type, and disallow other components from overlapping that + place. + Followed. The storage place for the tag field is the beginning of + the tagged record, and its size is Address'Size. GNAT will reject + an explicit component clause for the tag field. + + + An implementation need not support a `component_clause' for a + component of an extension part if the storage place is not after + the storage places of all components of the parent type, whether + or not those storage places had been specified. + Followed. The above advice on record representation clauses is + followed, and all mentioned features are implemented. + + *13.5.2(5): Storage Place Attributes* + + If a component is represented using some form of pointer (such as + an offset) to the actual data of the component, and this data is + contiguous with the rest of the object, then the storage place + attributes should reflect the place of the actual data, not the + pointer. If a component is allocated discontinuously from the + rest of the object, then a warning should be generated upon + reference to one of its storage place attributes. + Followed. There are no such components in GNAT. + + *13.5.3(7-8): Bit Ordering* + + The recommended level of support for the non-default bit ordering + is: + + + If `Word_Size' = `Storage_Unit', then the implementation should + support the non-default bit ordering in addition to the default + bit ordering. + Followed. Word size does not equal storage size in this + implementation. Thus non-default bit ordering is not supported. + + *13.7(37): Address as Private* + + `Address' should be of a private type. + Followed. + + *13.7.1(16): Address Operations* + + Operations in `System' and its children should reflect the target + environment semantics as closely as is reasonable. For example, + on most machines, it makes sense for address arithmetic to "wrap + around". Operations that do not make sense should raise + `Program_Error'. + Followed. Address arithmetic is modular arithmetic that wraps + around. No operation raises `Program_Error', since all operations + make sense. + + *13.9(14-17): Unchecked Conversion* + + The `Size' of an array object should not include its bounds; hence, + the bounds should not be part of the converted data. + Followed. + + + The implementation should not generate unnecessary run-time checks + to ensure that the representation of S is a representation of the + target type. It should take advantage of the permission to return + by reference when possible. Restrictions on unchecked conversions + should be avoided unless required by the target environment. + Followed. There are no restrictions on unchecked conversion. A + warning is generated if the source and target types do not have + the same size since the semantics in this case may be target + dependent. + + + The recommended level of support for unchecked conversions is: + + + Unchecked conversions should be supported and should be reversible + in the cases where this clause defines the result. To enable + meaningful use of unchecked conversion, a contiguous + representation should be used for elementary subtypes, for + statically constrained array subtypes whose component subtype is + one of the subtypes described in this paragraph, and for record + subtypes without discriminants whose component subtypes are + described in this paragraph. + Followed. + + *13.11(23-25): Implicit Heap Usage* + + An implementation should document any cases in which it dynamically + allocates heap storage for a purpose other than the evaluation of + an allocator. + Followed, the only other points at which heap storage is + dynamically allocated are as follows: + + * At initial elaboration time, to allocate dynamically sized + global objects. + + * To allocate space for a task when a task is created. + + * To extend the secondary stack dynamically when needed. The + secondary stack is used for returning variable length results. + + + A default (implementation-provided) storage pool for an + access-to-constant type should not have overhead to support + deallocation of individual objects. + Followed. + + + A storage pool for an anonymous access type should be created at + the point of an allocator for the type, and be reclaimed when the + designated object becomes inaccessible. + Followed. + + *13.11.2(17): Unchecked De-allocation* + + For a standard storage pool, `Free' should actually reclaim the + storage. + Followed. + + *13.13.2(17): Stream Oriented Attributes* + + If a stream element is the same size as a storage element, then the + normal in-memory representation should be used by `Read' and + `Write' for scalar objects. Otherwise, `Read' and `Write' should + use the smallest number of stream elements needed to represent all + values in the base range of the scalar type. + Followed. In particular, the interpretation chosen is that of + AI-195, which specifies that the size to be used is that of the + first subtype. + + *A.1(52): Implementation Advice* + + If an implementation provides additional named predefined integer + types, then the names should end with `Integer' as in + `Long_Integer'. If an implementation provides additional named + predefined floating point types, then the names should end with + `Float' as in `Long_Float'. + Followed. + + *A.3.2(49): `Ada.Characters.Handling'* + + If an implementation provides a localized definition of `Character' + or `Wide_Character', then the effects of the subprograms in + `Characters.Handling' should reflect the localizations. See also + 3.5.2. + Followed. GNAT provides no such localized definitions. + + *A.4.4(106): Bounded-Length String Handling* + + Bounded string objects should not be implemented by implicit + pointers and dynamic allocation. + Followed. No implicit pointers or dynamic allocation are used. + + *A.5.2(46-47): Random Number Generation* + + Any storage associated with an object of type `Generator' should be + reclaimed on exit from the scope of the object. + Followed. + + + If the generator period is sufficiently long in relation to the + number of distinct initiator values, then each possible value of + `Initiator' passed to `Reset' should initiate a sequence of random + numbers that does not, in a practical sense, overlap the sequence + initiated by any other value. If this is not possible, then the + mapping between initiator values and generator states should be a + rapidly varying function of the initiator value. + Followed. The generator period is sufficiently long for the first + condition here to hold true. + + *A.10.7(23): `Get_Immediate'* + + The `Get_Immediate' procedures should be implemented with + unbuffered input. For a device such as a keyboard, input should be + "available" if a key has already been typed, whereas for a disk + file, input should always be available except at end of file. For + a file associated with a keyboard-like device, any line-editing + features of the underlying operating system should be disabled + during the execution of `Get_Immediate'. + Followed. + + *B.1(39-41): Pragma `Export'* + + If an implementation supports pragma `Export' to a given language, + then it should also allow the main subprogram to be written in that + language. It should support some mechanism for invoking the + elaboration of the Ada library units included in the system, and + for invoking the finalization of the environment task. On typical + systems, the recommended mechanism is to provide two subprograms + whose link names are `adainit' and `adafinal'. `adainit' should + contain the elaboration code for library units. `adafinal' should + contain the finalization code. These subprograms should have no + effect the second and subsequent time they are called. + Followed. + + + Automatic elaboration of pre-elaborated packages should be + provided when pragma `Export' is supported. + Followed when the main program is in Ada. If the main program is + in a foreign language, then `adainit' must be called to elaborate + pre-elaborated packages. + + + For each supported convention L other than `Intrinsic', an + implementation should support `Import' and `Export' pragmas for + objects of L-compatible types and for subprograms, and pragma + `Convention' for L-eligible types and for subprograms, presuming + the other language has corresponding features. Pragma + `Convention' need not be supported for scalar types. + Followed. + + *B.2(12-13): Package `Interfaces'* + + For each implementation-defined convention identifier, there + should be a child package of package Interfaces with the + corresponding name. This package should contain any declarations + that would be useful for interfacing to the language + (implementation) represented by the convention. Any declarations + useful for interfacing to any language on the given hardware + architecture should be provided directly in `Interfaces'. + Followed. An additional package not defined in the Ada 95 + Reference Manual is `Interfaces.CPP', used for interfacing to C++. + + + An implementation supporting an interface to C, COBOL, or Fortran + should provide the corresponding package or packages described in + the following clauses. + Followed. GNAT provides all the packages described in this + section. + + *B.3(63-71): Interfacing with C* + + An implementation should support the following interface + correspondences between Ada and C. + Followed. + + + An Ada procedure corresponds to a void-returning C function. + Followed. + + + An Ada function corresponds to a non-void C function. + Followed. + + + An Ada `in' scalar parameter is passed as a scalar argument to a C + function. + Followed. + + + An Ada `in' parameter of an access-to-object type with designated + type T is passed as a `T*' argument to a C function, where T is + the C type corresponding to the Ada type T. + Followed. + + + An Ada access T parameter, or an Ada `out' or `in out' parameter + of an elementary type T, is passed as a `T*' argument to a C + function, where T is the C type corresponding to the Ada type T. + In the case of an elementary `out' or `in out' parameter, a + pointer to a temporary copy is used to preserve by-copy semantics. + Followed. + + + An Ada parameter of a record type T, of any mode, is passed as a + `T*' argument to a C function, where T is the C structure + corresponding to the Ada type T. + Followed. This convention may be overridden by the use of the + C_Pass_By_Copy pragma, or Convention, or by explicitly specifying + the mechanism for a given call using an extended import or export + pragma. + + + An Ada parameter of an array type with component type T, of any + mode, is passed as a `T*' argument to a C function, where T is the + C type corresponding to the Ada type T. + Followed. + + + An Ada parameter of an access-to-subprogram type is passed as a + pointer to a C function whose prototype corresponds to the + designated subprogram's specification. + Followed. + + *B.4(95-98): Interfacing with COBOL* + + An Ada implementation should support the following interface + correspondences between Ada and COBOL. + Followed. + + + An Ada access T parameter is passed as a `BY REFERENCE' data item + of the COBOL type corresponding to T. + Followed. + + + An Ada in scalar parameter is passed as a `BY CONTENT' data item of + the corresponding COBOL type. + Followed. + + + Any other Ada parameter is passed as a `BY REFERENCE' data item of + the COBOL type corresponding to the Ada parameter type; for + scalars, a local copy is used if necessary to ensure by-copy + semantics. + Followed. + + *B.5(22-26): Interfacing with Fortran* + + An Ada implementation should support the following interface + correspondences between Ada and Fortran: + Followed. + + + An Ada procedure corresponds to a Fortran subroutine. + Followed. + + + An Ada function corresponds to a Fortran function. + Followed. + + + An Ada parameter of an elementary, array, or record type T is + passed as a T argument to a Fortran procedure, where T is the + Fortran type corresponding to the Ada type T, and where the INTENT + attribute of the corresponding dummy argument matches the Ada + formal parameter mode; the Fortran implementation's parameter + passing conventions are used. For elementary types, a local copy + is used if necessary to ensure by-copy semantics. + Followed. + + + An Ada parameter of an access-to-subprogram type is passed as a + reference to a Fortran procedure whose interface corresponds to the + designated subprogram's specification. + Followed. + + *C.1(3-5): Access to Machine Operations* + + The machine code or intrinsic support should allow access to all + operations normally available to assembly language programmers for + the target environment, including privileged instructions, if any. + Followed. + + + The interfacing pragmas (see Annex B) should support interface to + assembler; the default assembler should be associated with the + convention identifier `Assembler'. + Followed. + + + If an entity is exported to assembly language, then the + implementation should allocate it at an addressable location, and + should ensure that it is retained by the linking process, even if + not otherwise referenced from the Ada code. The implementation + should assume that any call to a machine code or assembler + subprogram is allowed to read or update every object that is + specified as exported. + Followed. + + *C.1(10-16): Access to Machine Operations* + + The implementation should ensure that little or no overhead is + associated with calling intrinsic and machine-code subprograms. + Followed for both intrinsics and machine-code subprograms. + + + It is recommended that intrinsic subprograms be provided for + convenient access to any machine operations that provide special + capabilities or efficiency and that are not otherwise available + through the language constructs. + Followed. A full set of machine operation intrinsic subprograms + is provided. + + + Atomic read-modify-write operations--e.g., test and set, compare + and swap, decrement and test, enqueue/dequeue. + Followed on any target supporting such operations. + + + Standard numeric functions--e.g., sin, log. + Followed on any target supporting such operations. + + + String manipulation operations--e.g., translate and test. + Followed on any target supporting such operations. + + + Vector operations--e.g., compare vector against thresholds. + Followed on any target supporting such operations. + + + Direct operations on I/O ports. + Followed on any target supporting such operations. + + *C.3(28): Interrupt Support* + + If the `Ceiling_Locking' policy is not in effect, the + implementation should provide means for the application to specify + which interrupts are to be blocked during protected actions, if + the underlying system allows for a finer-grain control of + interrupt blocking. + Followed. The underlying system does not allow for finer-grain + control of interrupt blocking. + + *C.3.1(20-21): Protected Procedure Handlers* + + Whenever possible, the implementation should allow interrupt + handlers to be called directly by the hardware. + Followed on any target where the underlying operating system + permits such direct calls. + + + Whenever practical, violations of any implementation-defined + restrictions should be detected before run time. + Followed. Compile time warnings are given when possible. + + *C.3.2(25): Package `Interrupts'* + + If implementation-defined forms of interrupt handler procedures are + supported, such as protected procedures with parameters, then for + each such form of a handler, a type analogous to + `Parameterless_Handler' should be specified in a child package of + `Interrupts', with the same operations as in the predefined + package Interrupts. + Followed. + + *C.4(14): Pre-elaboration Requirements* + + It is recommended that pre-elaborated packages be implemented in + such a way that there should be little or no code executed at run + time for the elaboration of entities not already covered by the + Implementation Requirements. + Followed. Executable code is generated in some cases, e.g. loops + to initialize large arrays. + + *C.5(8): Pragma `Discard_Names'* + + If the pragma applies to an entity, then the implementation should + reduce the amount of storage used for storing names associated + with that entity. + Followed. + + *C.7.2(30): The Package Task_Attributes* + + Some implementations are targeted to domains in which memory use + at run time must be completely deterministic. For such + implementations, it is recommended that the storage for task + attributes will be pre-allocated statically and not from the heap. + This can be accomplished by either placing restrictions on the + number and the size of the task's attributes, or by using the + pre-allocated storage for the first N attribute objects, and the + heap for the others. In the latter case, N should be documented. + Not followed. This implementation is not targeted to such a + domain. + + *D.3(17): Locking Policies* + + The implementation should use names that end with `_Locking' for + locking policies defined by the implementation. + Followed. A single implementation-defined locking policy is + defined, whose name (`Inheritance_Locking') follows this + suggestion. + + *D.4(16): Entry Queuing Policies* + + Names that end with `_Queuing' should be used for all + implementation-defined queuing policies. + Followed. No such implementation-defined queueing policies exist. + + *D.6(9-10): Preemptive Abort* + + Even though the `abort_statement' is included in the list of + potentially blocking operations (see 9.5.1), it is recommended + that this statement be implemented in a way that never requires + the task executing the `abort_statement' to block. + Followed. + + + On a multi-processor, the delay associated with aborting a task on + another processor should be bounded; the implementation should use + periodic polling, if necessary, to achieve this. + Followed. + + *D.7(21): Tasking Restrictions* + + When feasible, the implementation should take advantage of the + specified restrictions to produce a more efficient implementation. + GNAT currently takes advantage of these restrictions by providing + an optimized run time when the Ravenscar profile and the GNAT + restricted run time set of restrictions are specified. See pragma + `Ravenscar' and pragma `Restricted_Run_Time' for more details. + + *D.8(47-49): Monotonic Time* + + When appropriate, implementations should provide configuration + mechanisms to change the value of `Tick'. + Such configuration mechanisms are not appropriate to this + implementation and are thus not supported. + + + It is recommended that `Calendar.Clock' and `Real_Time.Clock' be + implemented as transformations of the same time base. + Followed. + + + It is recommended that the "best" time base which exists in the + underlying system be available to the application through `Clock'. + "Best" may mean highest accuracy or largest range. + Followed. + + *E.5(28-29): Partition Communication Subsystem* + + Whenever possible, the PCS on the called partition should allow for + multiple tasks to call the RPC-receiver with different messages and + should allow them to block until the corresponding subprogram body + returns. + Followed by GLADE, a separately supplied PCS that can be used with + GNAT. + + + The `Write' operation on a stream of type `Params_Stream_Type' + should raise `Storage_Error' if it runs out of space trying to + write the `Item' into the stream. + Followed by GLADE, a separately supplied PCS that can be used with + GNAT. + + *F(7): COBOL Support* + + If COBOL (respectively, C) is widely supported in the target + environment, implementations supporting the Information Systems + Annex should provide the child package `Interfaces.COBOL' + (respectively, `Interfaces.C') specified in Annex B and should + support a `convention_identifier' of COBOL (respectively, C) in + the interfacing pragmas (see Annex B), thus allowing Ada programs + to interface with programs written in that language. + Followed. + + *F.1(2): Decimal Radix Support* + + Packed decimal should be used as the internal representation for + objects of subtype S when S'Machine_Radix = 10. + Not followed. GNAT ignores S'Machine_Radix and always uses binary + representations. + + *G: Numerics* + + + If Fortran (respectively, C) is widely supported in the target + environment, implementations supporting the Numerics Annex should + provide the child package `Interfaces.Fortran' (respectively, + `Interfaces.C') specified in Annex B and should support a + `convention_identifier' of Fortran (respectively, C) in the + interfacing pragmas (see Annex B), thus allowing Ada programs to + interface with programs written in that language. + Followed. + + *G.1.1(56-58): Complex Types* + + + Because the usual mathematical meaning of multiplication of a + complex operand and a real operand is that of the scaling of both + components of the former by the latter, an implementation should + not perform this operation by first promoting the real operand to + complex type and then performing a full complex multiplication. + In systems that, in the future, support an Ada binding to IEC + 559:1989, the latter technique will not generate the required + result when one of the components of the complex operand is + infinite. (Explicit multiplication of the infinite component by + the zero component obtained during promotion yields a NaN that + propagates into the final result.) Analogous advice applies in the + case of multiplication of a complex operand and a pure-imaginary + operand, and in the case of division of a complex operand by a + real or pure-imaginary operand. + Not followed. + + + Similarly, because the usual mathematical meaning of addition of a + complex operand and a real operand is that the imaginary operand + remains unchanged, an implementation should not perform this + operation by first promoting the real operand to complex type and + then performing a full complex addition. In implementations in + which the `Signed_Zeros' attribute of the component type is `True' + (and which therefore conform to IEC 559:1989 in regard to the + handling of the sign of zero in predefined arithmetic operations), + the latter technique will not generate the required result when + the imaginary component of the complex operand is a negatively + signed zero. (Explicit addition of the negative zero to the zero + obtained during promotion yields a positive zero.) Analogous + advice applies in the case of addition of a complex operand and a + pure-imaginary operand, and in the case of subtraction of a + complex operand and a real or pure-imaginary operand. + Not followed. + + + Implementations in which `Real'Signed_Zeros' is `True' should + attempt to provide a rational treatment of the signs of zero + results and result components. As one example, the result of the + `Argument' function should have the sign of the imaginary + component of the parameter `X' when the point represented by that + parameter lies on the positive real axis; as another, the sign of + the imaginary component of the `Compose_From_Polar' function + should be the same as (respectively, the opposite of) that of the + `Argument' parameter when that parameter has a value of zero and + the `Modulus' parameter has a nonnegative (respectively, negative) + value. + Followed. + + *G.1.2(49): Complex Elementary Functions* + + Implementations in which `Complex_Types.Real'Signed_Zeros' is + `True' should attempt to provide a rational treatment of the signs + of zero results and result components. For example, many of the + complex elementary functions have components that are odd + functions of one of the parameter components; in these cases, the + result component should have the sign of the parameter component + at the origin. Other complex elementary functions have zero + components whose sign is opposite that of a parameter component at + the origin, or is always positive or always negative. + Followed. + + *G.2.4(19): Accuracy Requirements* + + The versions of the forward trigonometric functions without a + `Cycle' parameter should not be implemented by calling the + corresponding version with a `Cycle' parameter of + `2.0*Numerics.Pi', since this will not provide the required + accuracy in some portions of the domain. For the same reason, the + version of `Log' without a `Base' parameter should not be + implemented by calling the corresponding version with a `Base' + parameter of `Numerics.e'. + Followed. + + *G.2.6(15): Complex Arithmetic Accuracy* + + The version of the `Compose_From_Polar' function without a `Cycle' + parameter should not be implemented by calling the corresponding + version with a `Cycle' parameter of `2.0*Numerics.Pi', since this + will not provide the required accuracy in some portions of the + domain. + Followed. + +  + File: gnat_rm.info, Node: Implementation Defined Characteristics, Next: Intrinsic Subprograms, Prev: Implementation Advice, Up: Top + + Implementation Defined Characteristics + ************************************** + + In addition to the implementation dependent pragmas and attributes, + and the implementation advice, there are a number of other features of + Ada 95 that are potentially implementation dependent. These are + mentioned throughout the Ada 95 Reference Manual, and are summarized in + annex M. + + A requirement for conforming Ada compilers is that they provide + documentation describing how the implementation deals with each of these + issues. In this chapter, you will find each point in annex M listed + followed by a description in italic font of how GNAT handles the + implementation dependence. + + You can use this chapter as a guide to minimizing implementation + dependent features in your programs if portability to other compilers + and other operating systems is an important consideration. The numbers + in each section below correspond to the paragraph number in the Ada 95 + Reference Manual. + + + *2*. Whether or not each recommendation given in Implementation Advice + is followed. See 1.1.2(37). + + *Note Implementation Advice::. + + + *3*. Capacity limitations of the implementation. See 1.1.3(3). + + The complexity of programs that can be processed is limited only by the + total amount of available virtual memory, and disk space for the + generated object files. + + + *4*. Variations from the standard that are impractical to avoid given + the implementation's execution environment. See 1.1.3(6). + + There are no variations from the standard. + + + *5*. Which `code_statement's cause external interactions. See + 1.1.3(10). + + Any `code_statement' can potentially cause external interactions. + + + *6*. The coded representation for the text of an Ada program. See + 2.1(4). + + See separate section on source representation. + + + *7*. The control functions allowed in comments. See 2.1(14). + + See separate section on source representation. + + + *8*. The representation for an end of line. See 2.2(2). + + See separate section on source representation. + + + *9*. Maximum supported line length and lexical element length. See + 2.2(15). + + The maximum line length is 255 characters an the maximum length of a + lexical element is also 255 characters. + + + *10*. Implementation defined pragmas. See 2.8(14). + + *Note Implementation Defined Pragmas::. + + + *11*. Effect of pragma `Optimize'. See 2.8(27). + + Pragma `Optimize', if given with a `Time' or `Space' parameter, checks + that the optimization flag is set, and aborts if it is not. + + + *12*. The sequence of characters of the value returned by `S'Image' + when some of the graphic characters of `S'Wide_Image' are not defined + in `Character'. See 3.5(37). + + The sequence of characters is as defined by the wide character encoding + method used for the source. See section on source representation for + further details. + + + *13*. The predefined integer types declared in `Standard'. See + 3.5.4(25). + + `Short_Short_Integer' + 8 bit signed + + `Short_Integer' + (Short) 16 bit signed + + `Integer' + 32 bit signed + + `Long_Integer' + 64 bit signed (Alpha OpenVMS only) 32 bit signed (all other + targets) + + `Long_Long_Integer' + 64 bit signed + + + *14*. Any nonstandard integer types and the operators defined for + them. See 3.5.4(26). + + There are no nonstandard integer types. + + + *15*. Any nonstandard real types and the operators defined for them. + See 3.5.6(8). + + There are no nonstandard real types. + + + *16*. What combinations of requested decimal precision and range are + supported for floating point types. See 3.5.7(7). + + The precision and range is as defined by the IEEE standard. + + + *17*. The predefined floating point types declared in `Standard'. See + 3.5.7(16). + + `Short_Float' + 32 bit IEEE short + + `Float' + (Short) 32 bit IEEE short + + `Long_Float' + 64 bit IEEE long + + `Long_Long_Float' + 64 bit IEEE long (80 bit IEEE long on x86 processors) + + + *18*. The small of an ordinary fixed point type. See 3.5.9(8). + + `Fine_Delta' is 2**(-63) + + + *19*. What combinations of small, range, and digits are supported for + fixed point types. See 3.5.9(10). + + Any combinations are permitted that do not result in a small less than + `Fine_Delta' and do not result in a mantissa larger than 63 bits. If + the mantissa is larger than 53 bits on machines where Long_Long_Float + is 64 bits (true of all architectures except ia32), then the output from + Text_IO is accurate to only 53 bits, rather than the full mantissa. + This is because floating-point conversions are used to convert fixed + point. + + + *20*. The result of `Tags.Expanded_Name' for types declared within an + unnamed `block_statement'. See 3.9(10). + + Block numbers of the form `BNNN', where NNN is a decimal integer are + allocated. + + + *21*. Implementation-defined attributes. See 4.1.4(12). + + *Note Implementation Defined Attributes::. + + + *22*. Any implementation-defined time types. See 9.6(6). + + There are no implementation-defined time types. + + + *23*. The time base associated with relative delays. + + See 9.6(20). The time base used is that provided by the C library + function `gettimeofday'. + + + *24*. The time base of the type `Calendar.Time'. See 9.6(23). + + The time base used is that provided by the C library function + `gettimeofday'. + + + *25*. The time zone used for package `Calendar' operations. See + 9.6(24). + + The time zone used by package `Calendar' is the current system time zone + setting for local time, as accessed by the C library function + `localtime'. + + + *26*. Any limit on `delay_until_statements' of `select_statements'. + See 9.6(29). + + There are no such limits. + + + *27*. Whether or not two non overlapping parts of a composite object + are independently addressable, in the case where packing, record + layout, or `Component_Size' is specified for the object. See 9.10(1). + + Separate components are independently addressable if they do not share + overlapping storage units. + + + *28*. The representation for a compilation. See 10.1(2). + + A compilation is represented by a sequence of files presented to the + compiler in a single invocation of the `gcc' command. + + + *29*. Any restrictions on compilations that contain multiple + compilation_units. See 10.1(4). + + No single file can contain more than one compilation unit, but any + sequence of files can be presented to the compiler as a single + compilation. + + + *30*. The mechanisms for creating an environment and for adding and + replacing compilation units. See 10.1.4(3). + + See separate section on compilation model. + + + *31*. The manner of explicitly assigning library units to a partition. + See 10.2(2). + + If a unit contains an Ada main program, then the Ada units for the + partition are determined by recursive application of the rules in the + Ada Reference Manual section 10.2(2-6). In other words, the Ada units + will be those that are needed by the main program, and then this + definition of need is applied recursively to those units, and the + partition contains the transitive closure determined by this + relationship. In short, all the necessary units are included, with no + need to explicitly specify the list. If additional units are required, + e.g. by foreign language units, then all units must be mentioned in the + context clause of one of the needed Ada units. + + If the partition contains no main program, or if the main program is + in a language other than Ada, then GNAT provides the binder options + `-z' and `-n' respectively, and in this case a list of units can be + explicitly supplied to the binder for inclusion in the partition (all + units needed by these units will also be included automatically). For + full details on the use of these options, refer to the `GNAT User's + Guide' sections on Binding and Linking. + + + *32*. The implementation-defined means, if any, of specifying which + compilation units are needed by a given compilation unit. See 10.2(2). + + The units needed by a given compilation unit are as defined in the Ada + Reference Manual section 10.2(2-6). There are no + implementation-defined pragmas or other implementation-defined means + for specifying needed units. + + + *33*. The manner of designating the main subprogram of a partition. + See 10.2(7). + + The main program is designated by providing the name of the + corresponding `ALI' file as the input parameter to the binder. + + + *34*. The order of elaboration of `library_items'. See 10.2(18). + + The first constraint on ordering is that it meets the requirements of + chapter 10 of the Ada 95 Reference Manual. This still leaves some + implementation dependent choices, which are resolved by first + elaborating bodies as early as possible (i.e. in preference to specs + where there is a choice), and second by evaluating the immediate with + clauses of a unit to determine the probably best choice, and third by + elaborating in alphabetical order of unit names where a choice still + remains. + + + *35*. Parameter passing and function return for the main subprogram. + See 10.2(21). + + The main program has no parameters. It may be a procedure, or a + function returning an integer type. In the latter case, the returned + integer value is the return code of the program. + + + *36*. The mechanisms for building and running partitions. See + 10.2(24). + + GNAT itself supports programs with only a single partition. The + GNATDIST tool provided with the GLADE package (which also includes an + implementation of the PCS) provides a completely flexible method for + building and running programs consisting of multiple partitions. See + the separate GLADE manual for details. + + + *37*. The details of program execution, including program termination. + See 10.2(25). + + See separate section on compilation model. + + + *38*. The semantics of any non-active partitions supported by the + implementation. See 10.2(28). + + Passive partitions are supported on targets where shared memory is + provided by the operating system. See the GLADE reference manual for + further details. + + + *39*. The information returned by `Exception_Message'. See 11.4.1(10). + + Exception message returns the null string unless a specific message has + been passed by the program. + + + *40*. The result of `Exceptions.Exception_Name' for types declared + within an unnamed `block_statement'. See 11.4.1(12). + + Blocks have implementation defined names of the form `BNNN' where NNN + is an integer. + + + *41*. The information returned by `Exception_Information'. See + 11.4.1(13). + + `Exception_Information' returns a string in the following format: + + _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 single `LF' character (`16#0A#'). + + + *42*. Implementation-defined check names. See 11.5(27). + + No implementation-defined check names are supported. + + + *43*. The interpretation of each aspect of representation. See + 13.1(20). + + See separate section on data representations. + + + *44*. Any restrictions placed upon representation items. See 13.1(20). + + See separate section on data representations. + + + *45*. The meaning of `Size' for indefinite subtypes. See 13.3(48). + + Size for an indefinite subtype is the maximum possible size, except that + for the case of a subprogram parameter, the size of the parameter object + is the actual size. + + + *46*. The default external representation for a type tag. See + 13.3(75). + + The default external representation for a type tag is the fully expanded + name of the type in upper case letters. + + + *47*. What determines whether a compilation unit is the same in two + different partitions. See 13.3(76). + + A compilation unit is the same in two different partitions if and only + if it derives from the same source file. + + + *48*. Implementation-defined components. See 13.5.1(15). + + The only implementation defined component is the tag for a tagged type, + which contains a pointer to the dispatching table. + + + *49*. If `Word_Size' = `Storage_Unit', the default bit ordering. See + 13.5.3(5). + + `Word_Size' (32) is not the same as `Storage_Unit' (8) for this + implementation, so no non-default bit ordering is supported. The + default bit ordering corresponds to the natural endianness of the + target architecture. + + + *50*. The contents of the visible part of package `System' and its + language-defined children. See 13.7(2). + + See the definition of these packages in files `system.ads' and + `s-stoele.ads'. + + + *51*. The contents of the visible part of package + `System.Machine_Code', and the meaning of `code_statements'. See + 13.8(7). + + See the definition and documentation in file `s-maccod.ads'. + + + *52*. The effect of unchecked conversion. See 13.9(11). + + Unchecked conversion between types of the same size and results in an + uninterpreted transmission of the bits from one type to the other. If + the types are of unequal sizes, then in the case of discrete types, a + shorter source is first zero or sign extended as necessary, and a + shorter target is simply truncated on the left. For all non-discrete + types, the source is first copied if necessary to ensure that the + alignment requirements of the target are met, then a pointer is + constructed to the source value, and the result is obtained by + dereferencing this pointer after converting it to be a pointer to the + target type. + + + *53*. The manner of choosing a storage pool for an access type when + `Storage_Pool' is not specified for the type. See 13.11(17). + + There are 3 different standard pools used by the compiler when + `Storage_Pool' is not specified depending whether the type is local to + a subprogram or defined at the library level and whether + `Storage_Size'is specified or not. See documentation in the runtime + library units `System.Pool_Global', `System.Pool_Size' and + `System.Pool_Local' in files `s-poosiz.ads', `s-pooglo.ads' and + `s-pooloc.ads' for full details on the default pools used. + + + *54*. Whether or not the implementation provides user-accessible names + for the standard pool type(s). See 13.11(17). + + See documentation in the sources of the run time mentioned in paragraph + *53* . All these pools are accessible by means of `with''ing these + units. + + + *55*. The meaning of `Storage_Size'. See 13.11(18). + + `Storage_Size' is measured in storage units, and refers to the total + space available for an access type collection, or to the primary stack + space for a task. + + + *56*. Implementation-defined aspects of storage pools. See 13.11(22). + + See documentation in the sources of the run time mentioned in paragraph + *53* for details on GNAT-defined aspects of storage pools. + + + *57*. The set of restrictions allowed in a pragma `Restrictions'. See + 13.12(7). + + All RM defined Restriction identifiers are implemented. The following + additional restriction identifiers are provided. There are two separate + lists of implementation dependent restriction identifiers. The first + set requires consistency throughout a partition (in other words, if the + restriction identifier is used for any compilation unit in the + partition, then all compilation units in the partition must obey the + restriction. + + `Boolean_Entry_Barriers' + This restriction ensures at compile time that barriers in entry + declarations for protected types are restricted to references to + simple boolean variables defined in the private part of the + protected type. No other form of entry barriers is permitted. + This is one of the restrictions of the Ravenscar profile for + limited tasking (see also pragma `Ravenscar'). + + `Max_Entry_Queue_Depth => Expr' + This restriction is a declaration that any protected entry + compiled in the scope of the restriction has at most the specified + number of tasks waiting on the entry at any one time, and so no + queue is required. This restriction is not checked at compile + time. A program execution is erroneous if an attempt is made to + queue more than the specified number of tasks on such an entry. + + `No_Calendar' + This restriction ensures at compile time that there is no implicit + or explicit dependence on the package `Ada.Calendar'. + + `No_Dynamic_Interrupts' + This restriction ensures at compile time that there is no attempt + to dynamically associate interrupts. Only static association is + allowed. + + `No_Enumeration_Maps' + This restriction ensures at compile time that no operations + requiring enumeration maps are used (that is Image and Value + attributes applied to enumeration types). + + `No_Entry_Calls_In_Elaboration_Code' + This restriction ensures at compile time that no task or protected + entry calls are made during elaboration code. As a result of the + use of this restriction, the compiler can assume that no code past + an accept statement in a task can be executed at elaboration time. + + `No_Exception_Handlers' + This restriction ensures at compile time that there are no explicit + exception handlers. + + `No_Implicit_Conditionals' + This restriction ensures that the generated code does not contain + any implicit conditionals, either by modifying the generated code + where possible, or by rejecting any construct that would otherwise + generate an implicit conditional. The details and use of this + restriction are described in more detail in the High Integrity + product documentation. + + `No_Implicit_Loops' + This restriction ensures that the generated code does not contain + any implicit `for' loops, either by modifying the generated code + where possible, or by rejecting any construct that would otherwise + generate an implicit `for' loop. The details and use of this + restriction are described in more detail in the High Integrity + product documentation. + + `No_Local_Protected_Objects' + This restriction ensures at compile time that protected objects are + only declared at the library level. + + `No_Protected_Type_Allocators' + This restriction ensures at compile time that there are no + allocator expressions that attempt to allocate protected objects. + + `No_Secondary_Stack' + This restriction ensures at compile time that the generated code + does not contain any reference to the secondary stack. The + secondary stack is used to implement functions returning + unconstrained objects (arrays or records) on some targets. The + details and use of this restriction are described in more detail + in the High Integrity product documentation. + + `No_Select_Statements' + This restriction ensures at compile time no select statements of + any kind are permitted, that is the keyword `select' may not + appear. This is one of the restrictions of the Ravenscar profile + for limited tasking (see also pragma `Ravenscar'). + + `No_Standard_Storage_Pools' + This restriction ensures at compile time that no access types use + the standard default storage pool. Any access type declared must + have an explicit Storage_Pool attribute defined specifying a + user-defined storage pool. + + `No_Streams' + This restriction ensures at compile time that there are no + implicit or explicit dependencies on the package `Ada.Streams'. + + `No_Task_Attributes' + This restriction ensures at compile time that there are no + implicit or explicit dependencies on the package + `Ada.Task_Attributes'. + + `No_Task_Termination' + This restriction ensures at compile time that no terminate + alternatives appear in any task body. + + `No_Tasking' + This restriction prevents the declaration of tasks or task types + throughout the partition. It is similar in effect to the use of + `Max_Tasks => 0' except that violations are caught at compile time + and cause an error message to be output either by the compiler or + binder. + + `No_Wide_Characters' + This restriction ensures at compile time that no uses of the types + `Wide_Character' or `Wide_String' appear, and that no wide + character literals appear in the program (that is literals + representing characters not in type `Character'. + + `Static_Priorities' + This restriction ensures at compile time that all priority + expressions are static, and that there are no dependencies on the + package `Ada.Dynamic_Priorities'. + + `Static_Storage_Size' + This restriction ensures at compile time that any expression + appearing in a Storage_Size pragma or attribute definition clause + is static. + + The second set of implementation dependent restriction identifiers does + not require partition-wide consistency. The restriction may be + enforced for a single compilation unit without any effect on any of the + other compilation units in the partition. + + `No_Elaboration_Code' + This restriction ensures at compile time that no elaboration code + is generated. Note that this is not the same condition as is + enforced by pragma `Preelaborate'. There are cases in which + pragma `Preelaborate' still permits code to be generated (e.g. + code to initialize a large array to all zeroes), and there are + cases of units which do not meet the requirements for pragma + `Preelaborate', but for which no elaboration code is generated. + Generally, it is the case that preelaborable units will meet the + restrictions, with the exception of large aggregates initialized + with an others_clause, and exception declarations (which generate + calls to a run-time registry procedure). Note that this + restriction is enforced on a unit by unit basis, it need not be + obeyed consistently throughout a partition. + + `No_Entry_Queue' + This restriction is a declaration that any protected entry + compiled in the scope of the restriction has at most one task + waiting on the entry at any one time, and so no queue is required. + This restriction is not checked at compile time. A program + execution is erroneous if an attempt is made to queue a second + task on such an entry. + + `No_Implementation_Attributes' + This restriction checks at compile time that no GNAT-defined + attributes are present. With this restriction, the only + attributes that can be used are those defined in the Ada 95 + Reference Manual. + + `No_Implementation_Pragmas' + This restriction checks at compile time that no GNAT-defined + pragmas are present. With this restriction, the only pragmas that + can be used are those defined in the Ada 95 Reference Manual. + + `No_Implementation_Restrictions' + This restriction checks at compile time that no GNAT-defined + restriction identifiers (other than + `No_Implementation_Restrictions' itself) are present. With this + restriction, the only other restriction identifiers that can be + used are those defined in the Ada 95 Reference Manual. + + + *58*. The consequences of violating limitations on `Restrictions' + pragmas. See 13.12(9). + + Restrictions that can be checked at compile time result in illegalities + if violated. Currently there are no other consequences of violating + restrictions. + + + *59*. The representation used by the `Read' and `Write' attributes of + elementary types in terms of stream elements. See 13.13.2(9). + + The representation is the in-memory representation of the base type of + the type, using the number of bits corresponding to the `TYPE'Size' + value, and the natural ordering of the machine. + + + *60*. The names and characteristics of the numeric subtypes declared + in the visible part of package `Standard'. See A.1(3). + + See items describing the integer and floating-point types supported. + + + *61*. The accuracy actually achieved by the elementary functions. See + A.5.1(1). + + The elementary functions correspond to the functions available in the C + library. Only fast math mode is implemented. + + + *62*. The sign of a zero result from some of the operators or + functions in `Numerics.Generic_Elementary_Functions', when + `Float_Type'Signed_Zeros' is `True'. See A.5.1(46). + + The sign of zeroes follows the requirements of the IEEE 754 standard on + floating-point. + + + *63*. The value of `Numerics.Float_Random.Max_Image_Width'. See + A.5.2(27). + + Maximum image width is 649, see library file `a-numran.ads'. + + + *64*. The value of `Numerics.Discrete_Random.Max_Image_Width'. See + A.5.2(27). + + Maximum image width is 80, see library file `a-nudira.ads'. + + + *65*. The algorithms for random number generation. See A.5.2(32). + + The algorithm is documented in the source files `a-numran.ads' and + `a-numran.adb'. + + + *66*. The string representation of a random number generator's state. + See A.5.2(38). + + See the documentation contained in the file `a-numran.adb'. + + + *67*. The minimum time interval between calls to the time-dependent + Reset procedure that are guaranteed to initiate different random number + sequences. See A.5.2(45). + + The minimum period between reset calls to guarantee distinct series of + random numbers is one microsecond. + + + *68*. The values of the `Model_Mantissa', `Model_Emin', + `Model_Epsilon', `Model', `Safe_First', and `Safe_Last' attributes, if + the Numerics Annex is not supported. See A.5.3(72). + + See the source file `ttypef.ads' for the values of all numeric + attributes. + + + *69*. Any implementation-defined characteristics of the input-output + packages. See A.7(14). + + There are no special implementation defined characteristics for these + packages. + + + *70*. The value of `Buffer_Size' in `Storage_IO'. See A.9(10). + + All type representations are contiguous, and the `Buffer_Size' is the + value of `TYPE'Size' rounded up to the next storage unit boundary. + + + *71*. External files for standard input, standard output, and standard + error See A.10(5). + + These files are mapped onto the files provided by the C streams + libraries. See source file `i-cstrea.ads' for further details. + + + *72*. The accuracy of the value produced by `Put'. See A.10.9(36). + + If more digits are requested in the output than are represented by the + precision of the value, zeroes are output in the corresponding least + significant digit positions. + + + *73*. The meaning of `Argument_Count', `Argument', and `Command_Name'. + See A.15(1). + + These are mapped onto the `argv' and `argc' parameters of the main + program in the natural manner. + + + *74*. Implementation-defined convention names. See B.1(11). + + The following convention names are supported + + `Ada' + Ada + + `Assembler' + Assembly language + + `Asm' + Synonym for Assembler + + `Assembly' + Synonym for Assembler + + `C' + C + + `C_Pass_By_Copy' + Allowed only for record types, like C, but also notes that record + is to be passed by copy rather than reference. + + `COBOL' + COBOL + + `CPP' + C++ + + `Default' + Treated the same as C + + `External' + Treated the same as C + + `Fortran' + Fortran + + `Intrinsic' + For support of pragma `Import' with convention Intrinsic, see + separate section on Intrinsic Subprograms. + + `Stdcall' + Stdcall (used for Windows implementations only). This convention + correspond to the WINAPI (previously called Pascal convention) + C/C++ convention under Windows. A function with this convention + cleans the stack before exit. + + `DLL' + Synonym for Stdcall + + `Win32' + Synonym for Stdcall + + `Stubbed' + Stubbed is a special convention used to indicate that the body of + the subprogram will be entirely ignored. Any call to the + subprogram is converted into a raise of the `Program_Error' + exception. If a pragma `Import' specifies convention `stubbed' + then no body need be present at all. This convention is useful + during development for the inclusion of subprograms whose body has + not yet been written. + + In addition, all otherwise unrecognized convention names are also + treated as being synonymous with convention C. In all implementations + except for VMS, use of such other names results in a warning. In VMS + implementations, these names are accepted silently. + + + *75*. The meaning of link names. See B.1(36). + + Link names are the actual names used by the linker. + + + *76*. The manner of choosing link names when neither the link name nor + the address of an imported or exported entity is specified. See + B.1(36). + + The default linker name is that which would be assigned by the relevant + external language, interpreting the Ada name as being in all lower case + letters. + + + *77*. The effect of pragma `Linker_Options'. See B.1(37). + + The string passed to `Linker_Options' is presented uninterpreted as an + argument to the link command, unless it contains Ascii.NUL characters. + NUL characters if they appear act as argument separators, so for example + + pragma Linker_Options ("-labc" & ASCII.Nul & "-ldef"); + + causes two separate arguments `-labc' and `-ldef' to be passed to the + linker. The order of linker options is preserved for a given unit. The + final list of options passed to the linker is in reverse order of the + elaboration order. For example, linker options fo a body always appear + before the options from the corresponding package spec. + + + *78*. The contents of the visible part of package `Interfaces' and its + language-defined descendants. See B.2(1). + + See files with prefix `i-' in the distributed library. + + + *79*. Implementation-defined children of package `Interfaces'. The + contents of the visible part of package `Interfaces'. See B.2(11). + + See files with prefix `i-' in the distributed library. + + + *80*. The types `Floating', `Long_Floating', `Binary', `Long_Binary', + `Decimal_ Element', and `COBOL_Character'; and the initialization of + the variables `Ada_To_COBOL' and `COBOL_To_Ada', in `Interfaces.COBOL'. + See B.4(50). + + `Floating' + Float + + `Long_Floating' + (Floating) Long_Float + + `Binary' + Integer + + `Long_Binary' + Long_Long_Integer + + `Decimal_Element' + Character + + `COBOL_Character' + Character + + For initialization, see the file `i-cobol.ads' in the distributed + library. + + + *81*. Support for access to machine instructions. See C.1(1). + + See documentation in file `s-maccod.ads' in the distributed library. + + + *82*. Implementation-defined aspects of access to machine operations. + See C.1(9). + + See documentation in file `s-maccod.ads' in the distributed library. + + + *83*. Implementation-defined aspects of interrupts. See C.3(2). + + Interrupts are mapped to signals or conditions as appropriate. See + definition of unit `Ada.Interrupt_Names' in source file `a-intnam.ads' + for details on the interrupts supported on a particular target. + + + *84*. Implementation-defined aspects of pre-elaboration. See C.4(13). + + GNAT does not permit a partition to be restarted without reloading, + except under control of the debugger. + + + *85*. The semantics of pragma `Discard_Names'. See C.5(7). + + Pragma `Discard_Names' causes names of enumeration literals to be + suppressed. In the presence of this pragma, the Image attribute + provides the image of the Pos of the literal, and Value accepts Pos + values. + + + *86*. The result of the `Task_Identification.Image' attribute. See + C.7.1(7). + + The result of this attribute is an 8-digit hexadecimal string + representing the virtual address of the task control block. + + + *87*. The value of `Current_Task' when in a protected entry or + interrupt handler. See C.7.1(17). + + Protected entries or interrupt handlers can be executed by any + convenient thread, so the value of `Current_Task' is undefined. + + + *88*. The effect of calling `Current_Task' from an entry body or + interrupt handler. See C.7.1(19). + + The effect of calling `Current_Task' from an entry body or interrupt + handler is to return the identification of the task currently executing + the code. + + + *89*. Implementation-defined aspects of `Task_Attributes'. See + C.7.2(19). + + There are no implementation-defined aspects of `Task_Attributes'. + + + *90*. Values of all `Metrics'. See D(2). + + The metrics information for GNAT depends on the performance of the + underlying operating system. The sources of the run-time for tasking + implementation, together with the output from `-gnatG' can be used to + determine the exact sequence of operating systems calls made to + implement various tasking constructs. Together with appropriate + information on the performance of the underlying operating system, on + the exact target in use, this information can be used to determine the + required metrics. + + + *91*. The declarations of `Any_Priority' and `Priority'. See D.1(11). + + See declarations in file `system.ads'. + + + *92*. Implementation-defined execution resources. See D.1(15). + + There are no implementation-defined execution resources. + + + *93*. Whether, on a multiprocessor, a task that is waiting for access + to a protected object keeps its processor busy. See D.2.1(3). + + On a multi-processor, a task that is waiting for access to a protected + object does not keep its processor busy. + + + *94*. The affect of implementation defined execution resources on task + dispatching. See D.2.1(9). + + Tasks map to threads in the threads package used by GNAT. Where + possible and appropriate, these threads correspond to native threads of + the underlying operating system. + + + *95*. Implementation-defined `policy_identifiers' allowed in a pragma + `Task_Dispatching_Policy'. See D.2.2(3). + + There are no implementation-defined policy-identifiers allowed in this + pragma. + + + *96*. Implementation-defined aspects of priority inversion. See + D.2.2(16). + + Execution of a task cannot be preempted by the implementation processing + of delay expirations for lower priority tasks. + + + *97*. Implementation defined task dispatching. See D.2.2(18). + + The policy is the same as that of the underlying threads implementation. + + + *98*. Implementation-defined `policy_identifiers' allowed in a pragma + `Locking_Policy'. See D.3(4). + + The only implementation defined policy permitted in GNAT is + `Inheritance_Locking'. On targets that support this policy, locking is + implemented by inheritance, i.e. the task owning the lock operates at a + priority equal to the highest priority of any task currently requesting + the lock. + + + *99*. Default ceiling priorities. See D.3(10). + + The ceiling priority of protected objects of the type + `System.Interrupt_Priority'Last' as described in the Ada 95 Reference + Manual D.3(10), + + + *100*. The ceiling of any protected object used internally by the + implementation. See D.3(16). + + The ceiling priority of internal protected objects is + `System.Priority'Last'. + + + *101*. Implementation-defined queuing policies. See D.4(1). + + There are no implementation-defined queueing policies. + + + *102*. On a multiprocessor, any conditions that cause the completion + of an aborted construct to be delayed later than what is specified for + a single processor. See D.6(3). + + The semantics for abort on a multi-processor is the same as on a single + processor, there are no further delays. + + + *103*. Any operations that implicitly require heap storage allocation. + See D.7(8). + + The only operation that implicitly requires heap storage allocation is + task creation. + + + *104*. Implementation-defined aspects of pragma `Restrictions'. See + D.7(20). + + There are no such implementation-defined aspects. + + + *105*. Implementation-defined aspects of package `Real_Time'. See + D.8(17). + + There are no implementation defined aspects of package `Real_Time'. + + + *106*. Implementation-defined aspects of `delay_statements'. See + D.9(8). + + Any difference greater than one microsecond will cause the task to be + delayed (see D.9(7)). + + + *107*. The upper bound on the duration of interrupt blocking caused by + the implementation. See D.12(5). + + The upper bound is determined by the underlying operating system. In + no cases is it more than 10 milliseconds. + + + *108*. The means for creating and executing distributed programs. See + E(5). + + The GLADE package provides a utility GNATDIST for creating and executing + distributed programs. See the GLADE reference manual for further + details. + + + *109*. Any events that can result in a partition becoming + inaccessible. See E.1(7). + + See the GLADE reference manual for full details on such events. + + + *110*. The scheduling policies, treatment of priorities, and + management of shared resources between partitions in certain cases. See + E.1(11). + + See the GLADE reference manual for full details on these aspects of + multi-partition execution. + + + *111*. Events that cause the version of a compilation unit to change. + See E.3(5). + + Editing the source file of a compilation unit, or the source files of + any units on which it is dependent in a significant way cause the + version to change. No other actions cause the version number to + change. All changes are significant except those which affect only + layout, capitalization or comments. + + + *112*. Whether the execution of the remote subprogram is immediately + aborted as a result of cancellation. See E.4(13). + + See the GLADE reference manual for details on the effect of abort in a + distributed application. + + + *113*. Implementation-defined aspects of the PCS. See E.5(25). + + See the GLADE reference manual for a full description of all + implementation defined aspects of the PCS. + + + *114*. Implementation-defined interfaces in the PCS. See E.5(26). + + See the GLADE reference manual for a full description of all + implementation defined interfaces. + + + *115*. The values of named numbers in the package `Decimal'. See + F.2(7). + + `Max_Scale' + +18 + + `Min_Scale' + -18 + + `Min_Delta' + 1.0E-18 + + `Max_Delta' + 1.0E+18 + + `Max_Decimal_Digits' + 18 + + + *116*. The value of `Max_Picture_Length' in the package + `Text_IO.Editing'. See F.3.3(16). + + 64 + + + *117*. The value of `Max_Picture_Length' in the package + `Wide_Text_IO.Editing'. See F.3.4(5). + + 64 + + + *118*. The accuracy actually achieved by the complex elementary + functions and by other complex arithmetic operations. See G.1(1). + + Standard library functions are used for the complex arithmetic + operations. Only fast math mode is currently supported. + + + *119*. The sign of a zero result (or a component thereof) from any + operator or function in `Numerics.Generic_Complex_Types', when + `Real'Signed_Zeros' is True. See G.1.1(53). + + The signs of zero values are as recommended by the relevant + implementation advice. + + + *120*. The sign of a zero result (or a component thereof) from any + operator or function in + `Numerics.Generic_Complex_Elementary_Functions', when + `Real'Signed_Zeros' is `True'. See G.1.2(45). + + The signs of zero values are as recommended by the relevant + implementation advice. + + + *121*. Whether the strict mode or the relaxed mode is the default. + See G.2(2). + + The strict mode is the default. There is no separate relaxed mode. + GNAT provides a highly efficient implementation of strict mode. + + + *122*. The result interval in certain cases of fixed-to-float + conversion. See G.2.1(10). + + For cases where the result interval is implementation dependent, the + accuracy is that provided by performing all operations in 64-bit IEEE + floating-point format. + + + *123*. The result of a floating point arithmetic operation in overflow + situations, when the `Machine_Overflows' attribute of the result type + is `False'. See G.2.1(13). + + Infinite and Nan values are produced as dictated by the IEEE + floating-point standard. + + + *124*. The result interval for division (or exponentiation by a + negative exponent), when the floating point hardware implements division + as multiplication by a reciprocal. See G.2.1(16). + + Not relevant, division is IEEE exact. + + + *125*. The definition of close result set, which determines the + accuracy of certain fixed point multiplications and divisions. See + G.2.3(5). + + Operations in the close result set are performed using IEEE long format + floating-point arithmetic. The input operands are converted to + floating-point, the operation is done in floating-point, and the result + is converted to the target type. + + + *126*. Conditions on a `universal_real' operand of a fixed point + multiplication or division for which the result shall be in the perfect + result set. See G.2.3(22). + + The result is only defined to be in the perfect result set if the result + can be computed by a single scaling operation involving a scale factor + representable in 64-bits. + + + *127*. The result of a fixed point arithmetic operation in overflow + situations, when the `Machine_Overflows' attribute of the result type + is `False'. See G.2.3(27). + + Not relevant, `Machine_Overflows' is `True' for fixed-point types. + + + *128*. The result of an elementary function reference in overflow + situations, when the `Machine_Overflows' attribute of the result type + is `False'. See G.2.4(4). + + IEEE infinite and Nan values are produced as appropriate. + + + *129*. The value of the angle threshold, within which certain + elementary functions, complex arithmetic operations, and complex + elementary functions yield results conforming to a maximum relative + error bound. See G.2.4(10). + + Information on this subject is not yet available. + + + *130*. The accuracy of certain elementary functions for parameters + beyond the angle threshold. See G.2.4(10). + + Information on this subject is not yet available. + + + *131*. The result of a complex arithmetic operation or complex + elementary function reference in overflow situations, when the + `Machine_Overflows' attribute of the corresponding real type is + `False'. See G.2.6(5). + + IEEE infinite and Nan values are produced as appropriate. + + + *132*. The accuracy of certain complex arithmetic operations and + certain complex elementary functions for parameters (or components + thereof) beyond the angle threshold. See G.2.6(8). + + Information on those subjects is not yet available. + + + *133*. Information regarding bounded errors and erroneous execution. + See H.2(1). + + Information on this subject is not yet available. + + + *134*. Implementation-defined aspects of pragma `Inspection_Point'. + See H.3.2(8). + + Pragma `Inspection_Point' ensures that the variable is live and can be + examined by the debugger at the inspection point. + + + *135*. Implementation-defined aspects of pragma `Restrictions'. See + H.4(25). + + There are no implementation-defined aspects of pragma `Restrictions'. + The use of pragma `Restrictions [No_Exceptions]' has no effect on the + generated code. Checks must suppressed by use of pragma `Suppress'. + + + *136*. Any restrictions on pragma `Restrictions'. See H.4(27). + + There are no restrictions on pragma `Restrictions'. + +  + File: gnat_rm.info, Node: Intrinsic Subprograms, Next: Representation Clauses and Pragmas, Prev: Implementation Defined Characteristics, Up: Top + + Intrinsic Subprograms + ********************* + + * Menu: + + * Intrinsic Operators:: + * Enclosing_Entity:: + * Exception_Information:: + * Exception_Message:: + * Exception_Name:: + * File:: + * Line:: + * Rotate_Left:: + * Rotate_Right:: + * Shift_Left:: + * Shift_Right:: + * Shift_Right_Arithmetic:: + * Source_Location:: + + GNAT allows a user application program to write the declaration: + + pragma Import (Intrinsic, name); + + providing that the name corresponds to one of the implemented intrinsic + subprograms in GNAT, and that the parameter profile of the referenced + subprogram meets the requirements. This chapter describes the set of + implemented intrinsic subprograms, and the requirements on parameter + profiles. Note that no body is supplied; as with other uses of pragma + Import, the body is supplied elsewhere (in this case by the compiler + itself). Note that any use of this feature is potentially + non-portable, since the Ada standard does not require Ada compilers to + implement this feature. + +  + File: gnat_rm.info, Node: Intrinsic Operators, Next: Enclosing_Entity, Up: Intrinsic Subprograms + + Intrinsic Operators + =================== + + All the predefined numeric operators in package Standard in `pragma + Import (Intrinsic,..)' declarations. In the binary operator case, the + operands must have the same size. The operand or operands must also be + appropriate for the operator. For example, for addition, the operands + must both be floating-point or both be fixed-point, and the right + operand for `"**"' must have a root type of `Standard.Integer'Base'. + You can use an intrinsic operator declaration as in the following + example: + + type Int1 is new Integer; + type Int2 is new Integer; + + function "+" (X1 : Int1; X2 : Int2) return Int1; + function "+" (X1 : Int1; X2 : Int2) return Int2; + pragma Import (Intrinsic, "+"); + + This declaration would permit "mixed mode" arithmetic on items of the + differing types `Int1' and `Int2'. It is also possible to specify such + operators for private types, if the full views are appropriate + arithmetic types. + +  + File: gnat_rm.info, Node: Enclosing_Entity, Next: Exception_Information, Prev: Intrinsic Operators, Up: Intrinsic Subprograms + + Enclosing_Entity + ================ + + This intrinsic subprogram is used in the implementation of the library + routine `GNAT.Source_Info'. The only useful use of the intrinsic + import in this case is the one in this unit, so an application program + should simply call the function `GNAT.Source_Info.Enclosing_Entity' to + obtain the name of the current subprogram, package, task, entry, or + protected subprogram. + +  + File: gnat_rm.info, Node: Exception_Information, Next: Exception_Message, Prev: Enclosing_Entity, Up: Intrinsic Subprograms + + Exception_Information + ===================== + + This intrinsic subprogram is used in the implementation of the library + routine `GNAT.Current_Exception'. The only useful use of the intrinsic + import in this case is the one in this unit, so an application program + should simply call the function + `GNAT.Current_Exception.Exception_Information' to obtain the exception + information associated with the current exception. + +  + File: gnat_rm.info, Node: Exception_Message, Next: Exception_Name, Prev: Exception_Information, Up: Intrinsic Subprograms + + Exception_Message + ================= + + This intrinsic subprogram is used in the implementation of the library + routine `GNAT.Current_Exception'. The only useful use of the intrinsic + import in this case is the one in this unit, so an application program + should simply call the function + `GNAT.Current_Exception.Exception_Message' to obtain the message + associated with the current exception. + +  + File: gnat_rm.info, Node: Exception_Name, Next: File, Prev: Exception_Message, Up: Intrinsic Subprograms + + Exception_Name + ============== + + This intrinsic subprogram is used in the implementation of the library + routine `GNAT.Current_Exception'. The only useful use of the intrinsic + import in this case is the one in this unit, so an application program + should simply call the function `GNAT.Current_Exception.Exception_Name' + to obtain the name of the current exception. + +  + File: gnat_rm.info, Node: File, Next: Line, Prev: Exception_Name, Up: Intrinsic Subprograms + + File + ==== + + This intrinsic subprogram is used in the implementation of the library + routine `GNAT.Source_Info'. The only useful use of the intrinsic + import in this case is the one in this unit, so an application program + should simply call the function `GNAT.Source_Info.File' to obtain the + name of the current file. + +  + File: gnat_rm.info, Node: Line, Next: Rotate_Left, Prev: File, Up: Intrinsic Subprograms + + Line + ==== + + This intrinsic subprogram is used in the implementation of the library + routine `GNAT.Source_Info'. The only useful use of the intrinsic + import in this case is the one in this unit, so an application program + should simply call the function `GNAT.Source_Info.Line' to obtain the + number of the current source line. + +  + File: gnat_rm.info, Node: Rotate_Left, Next: Rotate_Right, Prev: Line, Up: Intrinsic Subprograms + + Rotate_Left + =========== + + In standard Ada 95, the `Rotate_Left' function is available only for + the predefined modular types in package `Interfaces'. However, in GNAT + it is possible to define a Rotate_Left function for a user defined + modular type or any signed integer type as in this example: + + function Shift_Left + (Value : My_Modular_Type; + Amount : Natural) + return My_Modular_Type; + + The requirements are that the profile be exactly as in the example + above. The only modifications allowed are in the formal parameter + names, and in the type of `Value' and the return type, which must be + the same, and must be either a signed integer type, or a modular + integer type with a binary modulus, and the size must be 8. 16, 32 or + 64 bits. + +  + File: gnat_rm.info, Node: Rotate_Right, Next: Shift_Left, Prev: Rotate_Left, Up: Intrinsic Subprograms + + Rotate_Right + ============ + + A `Rotate_Right' function can be defined for any user defined binary + modular integer type, or signed integer type, as described above for + `Rotate_Left'. + +  + File: gnat_rm.info, Node: Shift_Left, Next: Shift_Right, Prev: Rotate_Right, Up: Intrinsic Subprograms + + Shift_Left + ========== + + A `Shift_Left' function can be defined for any user defined binary + modular integer type, or signed integer type, as described above for + `Rotate_Left'. + +  + File: gnat_rm.info, Node: Shift_Right, Next: Shift_Right_Arithmetic, Prev: Shift_Left, Up: Intrinsic Subprograms + + Shift_Right + =========== + + A `Shift_Right' function can be defined for any user defined binary + modular integer type, or signed integer type, as described above for + `Rotate_Left'. + +  + File: gnat_rm.info, Node: Shift_Right_Arithmetic, Next: Source_Location, Prev: Shift_Right, Up: Intrinsic Subprograms + + Shift_Right_Arithmetic + ====================== + + A `Shift_Right_Arithmetic' function can be defined for any user defined + binary modular integer type, or signed integer type, as described above + for `Rotate_Left'. + +  + File: gnat_rm.info, Node: Source_Location, Prev: Shift_Right_Arithmetic, Up: Intrinsic Subprograms + + Source_Location + =============== + + This intrinsic subprogram is used in the implementation of the library + routine `GNAT.Source_Info'. The only useful use of the intrinsic + import in this case is the one in this unit, so an application program + should simply call the function `GNAT.Source_Info.Source_Location' to + obtain the current source file location. + +  + File: gnat_rm.info, Node: Representation Clauses and Pragmas, Next: Standard Library Routines, Prev: Intrinsic Subprograms, Up: Top + + Representation Clauses and Pragmas + ********************************** + + * Menu: + + * Alignment Clauses:: + * Size Clauses:: + * Storage_Size Clauses:: + * Size of Variant Record Objects:: + * Biased Representation :: + * Value_Size and Object_Size Clauses:: + * Component_Size Clauses:: + * Bit_Order Clauses:: + * Effect of Bit_Order on Byte Ordering:: + * Pragma Pack for Arrays:: + * Pragma Pack for Records:: + * Record Representation Clauses:: + * Enumeration Clauses:: + * Address Clauses:: + * Effect of Convention on Representation:: + * Determining the Representations chosen by GNAT:: + + This section describes the representation clauses accepted by GNAT, and + their effect on the representation of corresponding data objects. + + GNAT fully implements Annex C (Systems Programming). This means + that all the implementation advice sections in chapter 13 are fully + implemented. However, these sections only require a minimal level of + support for representation clauses. GNAT provides much more extensive + capabilities, and this section describes the additional capabilities + provided. + +  + File: gnat_rm.info, Node: Alignment Clauses, Next: Size Clauses, Up: Representation Clauses and Pragmas + + Alignment Clauses + ================= + + GNAT requires that all alignment clauses specify a power of 2, and all + default alignments are always a power of 2. The default alignment + values are as follows: + + * Primitive Types For primitive types, the alignment is the maximum + of the actual size of objects of the type, and the maximum + alignment supported by the target. For example, for type + Long_Float, the object size is 8 bytes, and the default alignment + will be 8 on any target that supports alignments this large, but + on some targets, the maximum alignment may be smaller than 8, in + which case objects of type Long_Float will be maximally aligned. + + * Arrays For arrays, the alignment is equal to the alignment of the + component type for the normal case where no packing or component + size is given. If the array is packed, and the packing is + effective (see separate section on packed arrays), then the + alignment will be one for long packed arrays, or arrays whose + length is not known at compile time. For short packed arrays, + which are handled internally as modular types, the alignment will + be as described for primitive types, e.g. a packed array of length + 31 bits will have an object size of four bytes, and an alignment + of 4. + + * Records For the normal non-packed case, the alignment of a record + is equal to the maximum alignment of any of its components. For + tagged records, this includes the implicit access type used for + the tag. If a pragma `Pack' is used and all fields are packable + (see separate section on pragma `Pack'), then the resulting + alignment is 1. + + A special case is when the size of the record is given explicitly, + or a full record representation clause is given, and the size of + the record is 2, 4, or 8 bytes. In this case, an alignment is + chosen to match the size of the record. For example, if we have: + + type Small is record + A, B : Character; + end record; + + then the default alignment of the record type `Small' is 2, not 1. + This leads to more efficient code when the record is treated as a + unit, and also allows the type to specified as `Atomic' on + architectures requiring strict alignment. + + + An alignment clause may always specify a larger alignment than the + default value, up to some maximum value dependent on the target + (obtainable by using the attribute reference System'Maximum_Alignment). + The only case in which it is permissible to specify a smaller + alignment than the default value is in the case of a record for which a + record representation clause is given. In this case, packable fields + for which a component clause is given still result in a default + alignment corresponding to the original type, but this may be + overridden, since these components in fact only require an alignment of + one byte. For example, given + + type v is record + a : integer; + end record; + + for v use record + a at 0 range 0 .. 31; + end record; + + for v'alignment use 1; + + The default alignment for the type `v' is 4, as a result of the integer + field in the record, but since this field is placed with a component + clause, it is permissible, as shown, to override the default alignment + of the record to a smaller value. + +  + File: gnat_rm.info, Node: Size Clauses, Next: Storage_Size Clauses, Prev: Alignment Clauses, Up: Representation Clauses and Pragmas + + Size Clauses + ============ + + The default size of types is as specified in the reference manual. For + objects, GNAT will generally increase the type size so that the object + size is a multiple of storage units, and also a multiple of the + alignment. For example + + type Smallint is range 1 .. 6; + + type Rec is record + y1 : integer; + y2 : boolean; + end record; + + In this example, `Smallint' has a size of 3, as specified by the RM + rules, but objects of this type will have a size of 8, since objects by + default occupy an integral number of storage units. On some targets, + notably older versions of the Digital Alpha, the size of stand alone + objects of this type may be 32, reflecting the inability of the + hardware to do byte load/stores. + + Similarly, the size of type `Rec' is 40 bits, but the alignment is + 4, so objects of this type will have their size increased to 64 bits so + that it is a multiple of the alignment. The reason for this decision, + which is in accordance with the specific note in RM 13.3(43): + + A Size clause should be supported for an object if the specified + Size is at least as large as its subtype's Size, and corresponds + to a size in storage elements that is a multiple of the object's + Alignment (if the Alignment is nonzero). + + An explicit size clause may be used to override the default size by + increasing it. For example, if we have: + + type My_Boolean is new Boolean; + for My_Boolean'Size use 32; + + then objects of this type will always be 32 bits long. In the case of + discrete types, the size can be increased up to 64 bits, with the effect + that the entire specified field is used to hold the value, sign- or + zero-extended as appropriate. If more than 64 bits is specified, then + padding space is allocated after the value, and a warning is issued that + there are unused bits. + + Similarly the size of records and arrays may be increased, and the + effect is to add padding bits after the value. This also causes a + warning message to be generated. + + The largest Size value permitted in GNAT is 2**32-1. Since this is a + Size in bits, this corresponds to an object of size 256 megabytes (minus + one). This limitation is true on all targets. The reason for this + limitation is that it improves the quality of the code in many cases if + it is known that a Size value can be accommodated in an object of type + Integer. + +  + File: gnat_rm.info, Node: Storage_Size Clauses, Next: Size of Variant Record Objects, Prev: Size Clauses, Up: Representation Clauses and Pragmas + + Storage_Size Clauses + ==================== + + For tasks, the `Storage_Size' clause specifies the amount of space to + be allocated for the task stack. This cannot be extended, and if the + stack is exhausted, then `Storage_Error' will be raised if stack + checking is enabled. If the default size of 20K bytes is insufficient, + then you need to use a `Storage_Size' attribute definition clause, or a + `Storage_Size' pragma in the task definition to set the appropriate + required size. A useful technique is to include in every task + definition a pragma of the form: + + pragma Storage_Size (Default_Stack_Size); + + Then Default_Stack_Size can be defined in a global package, and modified + as required. Any tasks requiring different task stack sizes from the + default can have an appropriate alternative reference in the pragma. + + For access types, the `Storage_Size' clause specifies the maximum + space available for allocation of objects of the type. If this space is + exceeded then `Storage_Error' will be raised by an allocation attempt. + In the case where the access type is declared local to a subprogram, the + use of a `Storage_Size' clause triggers automatic use of a special + predefined storage pool (`System.Pool_Size') that ensures that all + space for the pool is automatically reclaimed on exit from the scope in + which the type is declared. + + A special case recognized by the compiler is the specification of a + `Storage_Size' of zero for an access type. This means that no items + can be allocated from the pool, and this is recognized at compile time, + and all the overhead normally associated with maintaining a fixed size + storage pool is eliminated. Consider the following example: + + procedure p is + type R is array (Natural) of Character; + type P is access all R; + for P'Storage_Size use 0; + -- Above access type intended only for interfacing purposes + + y : P; + + procedure g (m : P); + pragma Import (C, g); + + -- ... + + begin + -- ... + y := new R; + end; + + As indicated in this example, these dummy storage pools are often + useful in connection with interfacing where no object will ever be + allocated. If you compile the above example, you get the warning: + + p.adb:16:09: warning: allocation from empty storage pool + p.adb:16:09: warning: Storage_Error will be raised at run time + + Of course in practice, there will not be any explicit allocators in the + case of such an access declaration. + +  + File: gnat_rm.info, Node: Size of Variant Record Objects, Next: Biased Representation, Prev: Storage_Size Clauses, Up: Representation Clauses and Pragmas + + Size of Variant Record Objects + ============================== + + An issue arises in the case of variant record objects of whether Size + gives information about a particular variant, or the maximum size + required for any variant. Consider the following program + + with Text_IO; use Text_IO; + procedure q is + type R1 (A : Boolean := False) is record + case A is + when True => X : Character; + when False => null; + end case; + end record; + + V1 : R1 (False); + V2 : R1; + + begin + Put_Line (Integer'Image (V1'Size)); + Put_Line (Integer'Image (V2'Size)); + end q; + + Here we are dealing with a variant record, where the True variant + requires 16 bits, and the False variant requires 8 bits. In the above + example, both V1 and V2 contain the False variant, which is only 8 bits + long. However, the result of running the program is: + + 8 + 16 + + The reason for the difference here is that the discriminant value of V1 + is fixed, and will always be False. It is not possible to assign a + True variant value to V1, therefore 8 bits is sufficient. On the other + hand, in the case of V2, the initial discriminant value is False (from + the default), but it is possible to assign a True variant value to V2, + therefore 16 bits must be allocated for V2 in the general case, even + fewer bits may be needed at any particular point during the program + execution. + + As can be seen from the output of this program, the `'Size' + attribute applied to such an object in GNAT gives the actual allocated + size of the variable, which is the largest size of any of the variants. + The Ada Reference Manual is not completely clear on what choice should + be made here, but the GNAT behavior seems most consistent with the + language in the RM. + + In some cases, it may be desirable to obtain the size of the current + variant, rather than the size of the largest variant. This can be + achieved in GNAT by making use of the fact that in the case of a + subprogram parameter, GNAT does indeed return the size of the current + variant (because a subprogram has no way of knowing how much space is + actually allocated for the actual). + + Consider the following modified version of the above program: + + with Text_IO; use Text_IO; + procedure q is + type R1 (A : Boolean := False) is record + case A is + when True => X : Character; + when False => null; + end case; + end record; + + V2 : R1; + + function Size (V : R1) return Integer is + begin + return V'Size; + end Size; + + begin + Put_Line (Integer'Image (V2'Size)); + Put_Line (Integer'IMage (Size (V2))); + V2 := (True, 'x'); + Put_Line (Integer'Image (V2'Size)); + Put_Line (Integer'IMage (Size (V2))); + end q; + + The output from this program is + + 16 + 8 + 16 + 16 + + Here we see that while the `'Size' attribute always returns the maximum + size, regardless of the current variant value, the `Size' function does + indeed return the size of the current variant value. + +  + File: gnat_rm.info, Node: Biased Representation, Next: Value_Size and Object_Size Clauses, Prev: Size of Variant Record Objects, Up: Representation Clauses and Pragmas + + Biased Representation + ===================== + + In the case of scalars with a range starting at other than zero, it is + possible in some cases to specify a size smaller than the default + minimum value, and in such cases, GNAT uses an unsigned biased + representation, in which zero is used to represent the lower bound, and + successive values represent successive values of the type. + + For example, suppose we have the declaration: + + type Small is range -7 .. -4; + for Small'Size use 2; + + Although the default size of type `Small' is 4, the `Size' clause is + accepted by GNAT and results in the following representation scheme: + + -7 is represented as 2#00# + -6 is represented as 2#01# + -5 is represented as 2#10# + -4 is represented as 2#11# + + Biased representation is only used if the specified `Size' clause + cannot be accepted in any other manner. These reduced sizes that force + biased representation can be used for all discrete types except for + enumeration types for which a representation clause is given. + +  + File: gnat_rm.info, Node: Value_Size and Object_Size Clauses, Next: Component_Size Clauses, Prev: Biased Representation, Up: Representation Clauses and Pragmas + + Value_Size and Object_Size Clauses + ================================== + + In Ada 95, the `Size' of a discrete type is the minimum number of bits + required to hold values of the type. Although this interpretation was + allowed in Ada 83, it was not required, and this requirement in practice + can cause some significant difficulties. For example, in most Ada 83 + compilers, `Natural'Size' was 32. However, in Ada-95, `Natural'Size' is + typically 31. This means that code may change in behavior when moving + from Ada 83 to Ada 95. For example, consider: + + type Rec is record; + A : Natural; + B : Natural; + end record; + + for Rec use record + for A use at 0 range 0 .. Natural'Size - 1; + for B use at 0 range Natural'Size .. 2 * Natural'Size - 1; + end record; + + In the above code, since the typical size of `Natural' objects is 32 + bits and `Natural'Size' is 31, the above code can cause unexpected + inefficient packing in Ada 95, and in general there are surprising + cases where the fact that the object size can exceed the size of the + type causes surprises. + + To help get around this problem GNAT provides two implementation + dependent attributes `Value_Size' and `Object_Size'. When applied to a + type, these attributes yield the size of the type (corresponding to the + RM defined size attribute), and the size of objects of the type + respectively. + + The `Object_Size' is used for determining the default size of + objects and components. This size value can be referred to using the + `Object_Size' attribute. The phrase "is used" here means that it is + the basis of the determination of the size. The backend is free to pad + this up if necessary for efficiency, e.g. an 8-bit stand-alone + character might be stored in 32 bits on a machine with no efficient + byte access instructions such as the Alpha. + + The default rules for the value of `Object_Size' for fixed-point and + discrete types are as follows: + + * The `Object_Size' for base subtypes reflect the natural hardware + size in bits (run the utility `gnatpsta' to find those values for + numeric types). Enumeration types and fixed-point base subtypes + have 8, 16, 32 or 64 bits for this size, depending on the range of + values to be stored. + + * The `Object_Size' of a subtype is the same as the `Object_Size' of + the type from which it is obtained. + + * The `Object_Size' of a derived base type is copied from the parent + base type, and the `Object_Size' of a derived first subtype is + copied from the parent first subtype. + + The `Value_Size' attribute is the number of bits required to store a + value of the type. This size can be referred to using the `Value_Size' + attribute. This value is used to determine how tightly to pack records + or arrays with components of this type, and also affects the semantics + of unchecked conversion (unchecked conversions where the `Value_Size' + values differ generate a warning, and are potentially target dependent). + + The default rules for the value of `Value_Size' are as follows: + + * The `Value_Size' for a base subtype is the minimum number of bits + required to store all values of the type (including the sign bit + only if negative values are possible). + + * If a subtype statically matches the first subtype of a given type, + then it has by default the same `Value_Size' as the first subtype. + This is a consequence of RM 13.1(14) ("if two subtypes statically + match, then their subtype-specific aspects are the same".) + + * All other subtypes have a `Value_Size' corresponding to the minimum + number of bits required to store all values of the subtype. For + dynamic bounds, it is assumed that the value can range down or up + to the corresponding bound of the ancestor + + The RM defined attribute `Size' corresponds to the `Value_Size' + attribute. + + The `Size' attribute may be defined for a first-named subtype. This + sets the `Value_Size' of the first-named subtype to the given value, + and the `Object_Size' of this first-named subtype to the given value + padded up to an appropriate boundary. It is a consequence of the + default rules above that this `Object_Size' will apply to all further + subtypes. On the other hand, `Value_Size' is affected only for the + first subtype, any dynamic subtypes obtained from it directly, and any + statically matching subtypes. The `Value_Size' of any other static + subtypes is not affected. + + `Value_Size' and `Object_Size' may be explicitly set for any subtype + using an attribute definition clause. Note that the use of these + attributes can cause the RM 13.1(14) rule to be violated. If two + access types reference aliased objects whose subtypes have differing + `Object_Size' values as a result of explicit attribute definition + clauses, then it is erroneous to convert from one access subtype to the + other. + + At the implementation level, Esize stores the Object_SIze and the + RM_Size field stores the `Value_Size' (and hence the value of the + `Size' attribute, which, as noted above, is equivalent to `Value_Size'). + + To get a feel for the difference, consider the following examples + (note that in each case the base is short_short_integer with a size of + 8): + + Object_Size Value_Size + + type x1 is range 0 .. 5; 8 3 + + type x2 is range 0 .. 5; + for x2'size use 12; 12 12 + + subtype x3 is x2 range 0 .. 3; 12 2 + + subtype x4 is x2'base range 0 .. 10; 8 4 + + subtype x5 is x2 range 0 .. dynamic; 12 (7) + + subtype x6 is x2'base range 0 .. dynamic; 8 (7) + + Note: the entries marked (7) are not actually specified by the Ada 95 + RM, but it seems in the spirit of the RM rules to allocate the minimum + number of bits known to be large enough to hold the given range of + values. + + So far, so good, but GNAT has to obey the RM rules, so the question + is under what conditions must the RM `Size' be used. The following is + a list of the occasions on which the RM `Size' must be used: + + * Component size for packed arrays or records + + * Value of the attribute `Size' for a type + + * Warning about sizes not matching for unchecked conversion + + For types other than discrete and fixed-point types, the `Object_Size' + and Value_Size are the same (and equivalent to the RM attribute `Size'). + Only `Size' may be specified for such types. + +  + File: gnat_rm.info, Node: Component_Size Clauses, Next: Bit_Order Clauses, Prev: Value_Size and Object_Size Clauses, Up: Representation Clauses and Pragmas + + Component_Size Clauses + ====================== + + Normally, the value specified in a component clause must be consistent + with the subtype of the array component with regard to size and + alignment. In other words, the value specified must be at least equal + to the size of this subtype, and must be a multiple of the alignment + value. + + In addition, component size clauses are allowed which cause the array + to be packed, by specifying a smaller value. The cases in which this + is allowed are for component size values in the range 1 through 63. + The value specified must not be smaller than the Size of the subtype. + GNAT will accurately honor all packing requests in this range. For + example, if we have: + + type r is array (1 .. 8) of Natural; + for r'Size use 31; + + then the resulting array has a length of 31 bytes (248 bits = 8 * 31). + Of course access to the components of such an array is considerably + less efficient than if the natural component size of 32 is used. + +  + File: gnat_rm.info, Node: Bit_Order Clauses, Next: Effect of Bit_Order on Byte Ordering, Prev: Component_Size Clauses, Up: Representation Clauses and Pragmas + + Bit_Order Clauses + ================= + + For record subtypes, GNAT permits the specification of the `Bit_Order' + attribute. The specification may either correspond to the default bit + order for the target, in which case the specification has no effect and + places no additional restrictions, or it may be for the non-standard + setting (that is the opposite of the default). + + In the case where the non-standard value is specified, the effect is + to renumber bits within each byte, but the ordering of bytes is not + affected. There are certain restrictions placed on component clauses + as follows: + + * Components fitting within a single storage unit. + + These are unrestricted, and the effect is merely to renumber bits. + For example if we are on a little-endian machine with + `Low_Order_First' being the default, then the following two + declarations have exactly the same effect: + + type R1 is record + A : Boolean; + B : Integer range 1 .. 120; + end record; + + for R1 use record + A at 0 range 0 .. 0; + B at 0 range 1 .. 7; + end record; + + type R2 is record + A : Boolean; + B : Integer range 1 .. 120; + end record; + + for R2'Bit_Order use High_Order_First; + + for R2 use record + A at 0 range 7 .. 7; + B at 0 range 0 .. 6; + end record; + + The useful application here is to write the second declaration + with the `Bit_Order' attribute definition clause, and know that it + will be treated the same, regardless of whether the target is + little-endian or big-endian. + + * Components occupying an integral number of bytes. + + These are components that exactly fit in two or more bytes. Such + component declarations are allowed, but have no effect, since it + is important to realize that the `Bit_Order' specification does + not affect the ordering of bytes. In particular, the following + attempt at getting an endian-independent integer does not work: + + type R2 is record + A : Integer; + end record; + + for R2'Bit_Order use High_Order_First; + + for R2 use record + A at 0 range 0 .. 31; + end record; + + This declaration will result in a little-endian integer on a + little-endian machine, and a big-endian integer on a big-endian + machine. If byte flipping is required for interoperability + between big- and little-endian machines, this must be explicitly + programmed. This capability is not provided by `Bit_Order'. + + * Components that are positioned across byte boundaries + + but do not occupy an integral number of bytes. Given that bytes + are not reordered, such fields would occupy a non-contiguous + sequence of bits in memory, requiring non-trivial code to + reassemble. They are for this reason not permitted, and any + component clause specifying such a layout will be flagged as + illegal by GNAT. + + + Since the misconception that Bit_Order automatically deals with all + endian-related incompatibilities is a common one, the specification of + a component field that is an integral number of bytes will always + generate a warning. This warning may be suppressed using `pragma + Suppress' if desired. The following section contains additional + details regarding the issue of byte ordering. + +  + File: gnat_rm.info, Node: Effect of Bit_Order on Byte Ordering, Next: Pragma Pack for Arrays, Prev: Bit_Order Clauses, Up: Representation Clauses and Pragmas + + Effect of Bit_Order on Byte Ordering + ==================================== + + In this section we will review the effect of the `Bit_Order' attribute + definition clause on byte ordering. Briefly, it has no effect at all, + but a detailed example will be helpful. Before giving this example, + let us review the precise definition of the effect of defining + `Bit_Order'. The effect of a non-standard bit order is described in + section 15.5.3 of the Ada Reference Manual: + + 2 A bit ordering is a method of interpreting the meaning of + the storage place attributes. + + To understand the precise definition of storage place attributes in + this context, we visit section 13.5.1 of the manual: + + 13 A record_representation_clause (without the mod_clause) + specifies the layout. The storage place attributes (see 13.5.2) + are taken from the values of the position, first_bit, and last_bit + expressions after normalizing those values so that first_bit is + less than Storage_Unit. + + The critical point here is that storage places are taken from the + values after normalization, not before. So the `Bit_Order' + interpretation applies to normalized values. The interpretation is + described in the later part of the 15.5.3 paragraph: + + 2 A bit ordering is a method of interpreting the meaning of + the storage place attributes. High_Order_First (known in the + vernacular as ``big endian'') means that the first bit of a + storage element (bit 0) is the most significant bit (interpreting + the sequence of bits that represent a component as an unsigned + integer value). Low_Order_First (known in the vernacular as + ``little endian'') means the opposite: the first bit is the + least significant. + + Note that the numbering is with respect to the bits of a storage unit. + In other words, the specification affects only the numbering of bits + within a single storage unit. + + We can make the effect clearer by giving an example. + + Suppose that we have an external device which presents two bytes, + the first byte presented, which is the first (low addressed byte) of + the two byte record is called Master, and the second byte is called + Slave. + + The left most (most significant bit is called Control for each byte, + and the remaining 7 bits are called V1, V2, ... V7, where V7 is the + rightmost (least significant) bit. + + On a big-endian machine, we can write the following representation + clause + + type Data is record + Master_Control : Bit; + Master_V1 : Bit; + Master_V2 : Bit; + Master_V3 : Bit; + Master_V4 : Bit; + Master_V5 : Bit; + Master_V6 : Bit; + Master_V7 : Bit; + Slave_Control : Bit; + Slave_V1 : Bit; + Slave_V2 : Bit; + Slave_V3 : Bit; + Slave_V4 : Bit; + Slave_V5 : Bit; + Slave_V6 : Bit; + Slave_V7 : Bit; + end record; + + for Data use record + Master_Control at 0 range 0 .. 0; + Master_V1 at 0 range 1 .. 1; + Master_V2 at 0 range 2 .. 2; + Master_V3 at 0 range 3 .. 3; + Master_V4 at 0 range 4 .. 4; + Master_V5 at 0 range 5 .. 5; + Master_V6 at 0 range 6 .. 6; + Master_V7 at 0 range 7 .. 7; + Slave_Control at 1 range 0 .. 0; + Slave_V1 at 1 range 1 .. 1; + Slave_V2 at 1 range 2 .. 2; + Slave_V3 at 1 range 3 .. 3; + Slave_V4 at 1 range 4 .. 4; + Slave_V5 at 1 range 5 .. 5; + Slave_V6 at 1 range 6 .. 6; + Slave_V7 at 1 range 7 .. 7; + end record; + + Now if we move this to a little endian machine, then the bit ordering + within the byte is backwards, so we have to rewrite the record rep + clause as: + + for Data use record + Master_Control at 0 range 7 .. 7; + Master_V1 at 0 range 6 .. 6; + Master_V2 at 0 range 5 .. 5; + Master_V3 at 0 range 4 .. 4; + Master_V4 at 0 range 3 .. 3; + Master_V5 at 0 range 2 .. 2; + Master_V6 at 0 range 1 .. 1; + Master_V7 at 0 range 0 .. 0; + Slave_Control at 1 range 7 .. 7; + Slave_V1 at 1 range 6 .. 6; + Slave_V2 at 1 range 5 .. 5; + Slave_V3 at 1 range 4 .. 4; + Slave_V4 at 1 range 3 .. 3; + Slave_V5 at 1 range 2 .. 2; + Slave_V6 at 1 range 1 .. 1; + Slave_V7 at 1 range 0 .. 0; + end record; + + It is a nuisance to have to rewrite the clause, especially if the + code has to be maintained on both machines. However, this is a case + that we can handle with the `Bit_Order' attribute if it is implemented. + Note that the implementation is not required on byte addressed + machines, but it is indeed implemented in GNAT. This means that we can + simply use the first record clause, together with the declaration + + for Data'Bit_Order use High_Order_First; + + and the effect is what is desired, namely the layout is exactly the + same, independent of whether the code is compiled on a big-endian or + little-endian machine. + + The important point to understand is that byte ordering is not + affected. A `Bit_Order' attribute definition never affects which byte + a field ends up in, only where it ends up in that byte. To make this + clear, let us rewrite the record rep clause of the previous example as: + + for Data'Bit_Order use High_Order_First; + for Data use record + Master_Control at 0 range 0 .. 0; + Master_V1 at 0 range 1 .. 1; + Master_V2 at 0 range 2 .. 2; + Master_V3 at 0 range 3 .. 3; + Master_V4 at 0 range 4 .. 4; + Master_V5 at 0 range 5 .. 5; + Master_V6 at 0 range 6 .. 6; + Master_V7 at 0 range 7 .. 7; + Slave_Control at 0 range 8 .. 8; + Slave_V1 at 0 range 9 .. 9; + Slave_V2 at 0 range 10 .. 10; + Slave_V3 at 0 range 11 .. 11; + Slave_V4 at 0 range 12 .. 12; + Slave_V5 at 0 range 13 .. 13; + Slave_V6 at 0 range 14 .. 14; + Slave_V7 at 0 range 15 .. 15; + end record; + + This is exactly equivalent to saying (a repeat of the first example): + + for Data'Bit_Order use High_Order_First; + for Data use record + Master_Control at 0 range 0 .. 0; + Master_V1 at 0 range 1 .. 1; + Master_V2 at 0 range 2 .. 2; + Master_V3 at 0 range 3 .. 3; + Master_V4 at 0 range 4 .. 4; + Master_V5 at 0 range 5 .. 5; + Master_V6 at 0 range 6 .. 6; + Master_V7 at 0 range 7 .. 7; + Slave_Control at 1 range 0 .. 0; + Slave_V1 at 1 range 1 .. 1; + Slave_V2 at 1 range 2 .. 2; + Slave_V3 at 1 range 3 .. 3; + Slave_V4 at 1 range 4 .. 4; + Slave_V5 at 1 range 5 .. 5; + Slave_V6 at 1 range 6 .. 6; + Slave_V7 at 1 range 7 .. 7; + end record; + + Why are they equivalent? Well take a specific field, the `Slave_V2' + field. The storage place attributes are obtained by normalizing the + values given so that the `First_Bit' value is less than 8. After + nromalizing the values (0,10,10) we get (1,2,2) which is exactly what + we specified in the other case. + + Now one might expect that the `Bit_Order' attribute might affect bit + numbering within the entire record component (two bytes in this case, + thus affecting which byte fields end up in), but that is not the way + this feature is defined, it only affects numbering of bits, not which + byte they end up in. + + Consequently it never makes sense to specify a starting bit number + greater than 7 (for a byte addressable field) if an attribute + definition for `Bit_Order' has been given, and indeed it may be + actively confusing to specify such a value, so the compiler generates a + warning for such usage. + + If you do need to control byte ordering then appropriate conditional + values must be used. If in our example, the slave byte came first on + some machines we might write: + + Master_Byte_First constant Boolean := ...; + + Master_Byte : constant Natural := + 1 - Boolean'Pos (Master_Byte_First); + Slave_Byte : constant Natural := + Boolean'Pos (Master_Byte_First); + + for Data'Bit_Order use High_Order_First; + for Data use record + Master_Control at Master_Byte range 0 .. 0; + Master_V1 at Master_Byte range 1 .. 1; + Master_V2 at Master_Byte range 2 .. 2; + Master_V3 at Master_Byte range 3 .. 3; + Master_V4 at Master_Byte range 4 .. 4; + Master_V5 at Master_Byte range 5 .. 5; + Master_V6 at Master_Byte range 6 .. 6; + Master_V7 at Master_Byte range 7 .. 7; + Slave_Control at Slave_Byte range 0 .. 0; + Slave_V1 at Slave_Byte range 1 .. 1; + Slave_V2 at Slave_Byte range 2 .. 2; + Slave_V3 at Slave_Byte range 3 .. 3; + Slave_V4 at Slave_Byte range 4 .. 4; + Slave_V5 at Slave_Byte range 5 .. 5; + Slave_V6 at Slave_Byte range 6 .. 6; + Slave_V7 at Slave_Byte range 7 .. 7; + end record; + + Now to switch between machines, all that is necessary is to set the + boolean constant `Master_Byte_First' in an appropriate manner. + +  + File: gnat_rm.info, Node: Pragma Pack for Arrays, Next: Pragma Pack for Records, Prev: Effect of Bit_Order on Byte Ordering, Up: Representation Clauses and Pragmas + + Pragma Pack for Arrays + ====================== + + Pragma `Pack' applied to an array has no effect unless the component + type is packable. For a component type to be packable, it must be one + of the following cases: + + * Any scalar type + + * Any fixed-point type + + * Any type whose size is specified with a size clause + + * Any packed array type with a static size + + For all these cases, if the component subtype size is in the range 1 + through 63, then the effect of the pragma `Pack' is exactly as though a + component size were specified giving the component subtype size. For + example if we have: + + type r is range 0 .. 17; + + type ar is array (1 .. 8) of r; + pragma Pack (ar); + + Then the component size of `ar' will be set to 5 (i.e. to `r'size', and + the size of the array `ar' will be exactly 40 bits. + + Note that in some cases this rather fierce approach to packing can + produce unexpected effects. For example, in Ada 95, type Natural + typically has a size of 31, meaning that if you pack an array of + Natural, you get 31-bit close packing, which saves a few bits, but + results in far less efficient access. Since many other Ada compilers + will ignore such a packing request, GNAT will generate a warning on + some uses of pragma `Pack' that it guesses might not be what is + intended. You can easily remove this warning by using an explicit + `Component_Size' setting instead, which never generates a warning, + since the intention of the programmer is clear in this case. + + GNAT treats packed arrays in one of two ways. If the size of the + array is known at compile time and is less than 64 bits, then + internally the array is represented as a single modular type, of + exactly the appropriate number of bits. If the length is greater than + 63 bits, or is not known at compile time, then the packed array is + represented as an array of bytes, and the length is always a multiple + of 8 bits. + +  + File: gnat_rm.info, Node: Pragma Pack for Records, Next: Record Representation Clauses, Prev: Pragma Pack for Arrays, Up: Representation Clauses and Pragmas + + Pragma Pack for Records + ======================= + + Pragma `Pack' applied to a record will pack the components to reduce + wasted space from alignment gaps and by reducing the amount of space + taken by components. We distinguish between package components and + non-packable components. Components of the following types are + considered packable: + + * All scalar types are packable. + + * All fixed-point types are represented internally as integers, and + are packable. + + * Small packed arrays, whose size does not exceed 64 bits, and where + the size is statically known at compile time, are represented + internally as modular integers, and so they are also packable. + + + All packable components occupy the exact number of bits corresponding to + their `Size' value, and are packed with no padding bits, i.e. they can + start on an arbitrary bit boundary. + + All other types are non-packable, they occupy an integral number of + storage units, and are placed at a boundary corresponding to their + alignment requirements. + + For example, consider the record + + type Rb1 is array (1 .. 13) of Boolean; + pragma Pack (rb1); + + type Rb2 is array (1 .. 65) of Boolean; + pragma Pack (rb2); + + type x2 is record + l1 : Boolean; + l2 : Duration; + l3 : Float; + l4 : Boolean; + l5 : Rb1; + l6 : Rb2; + end record; + pragma Pack (x2); + + The representation for the record x2 is as follows: + + for x2'Size use 224; + for x2 use record + l1 at 0 range 0 .. 0; + l2 at 0 range 1 .. 64; + l3 at 12 range 0 .. 31; + l4 at 16 range 0 .. 0; + l5 at 16 range 1 .. 13; + l6 at 18 range 0 .. 71; + end record; + + Studying this example, we see that the packable fields `l1' and `l2' are + of length equal to their sizes, and placed at specific bit boundaries + (and not byte boundaries) to eliminate padding. But `l3' is of a + non-packable float type, so it is on the next appropriate alignment + boundary. + + The next two fields are fully packable, so `l4' and `l5' are + minimally packed with no gaps. However, type `Rb2' is a packed array + that is longer than 64 bits, so it is itself non-packable. Thus the + `l6' field is aligned to the next byte boundary, and takes an integral + number of bytes, i.e. 72 bits. + +  + File: gnat_rm.info, Node: Record Representation Clauses, Next: Enumeration Clauses, Prev: Pragma Pack for Records, Up: Representation Clauses and Pragmas + + Record Representation Clauses + ============================= + + Record representation clauses may be given for all record types, + including types obtained by record extension. Component clauses are + allowed for any static component. The restrictions on component + clauses depend on the type of the component. + + For all components of an elementary type, the only restriction on + component clauses is that the size must be at least the 'Size value of + the type (actually the Value_Size). There are no restrictions due to + alignment, and such components may freely cross storage boundaries. + + Packed arrays with a size up to and including 64 bits are represented + internally using a modular type with the appropriate number of bits, and + thus the same lack of restriction applies. For example, if you declare: + + type R is array (1 .. 49) of Boolean; + pragma Pack (R); + for R'Size use 49; + + then a component clause for a component of type R may start on any + specified bit boundary, and may specify a value of 49 bits or greater. + + For non-primitive types, including packed arrays with a size greater + than 64 bits, component clauses must respect the alignment requirement + of the type, in particular, always starting on a byte boundary, and the + length must be a multiple of the storage unit. + + The tag field of a tagged type always occupies an address sized + field at the start of the record. No component clause may attempt to + overlay this tag. + + In the case of a record extension T1, of a type T, no component + clause applied to the type T1 can specify a storage location that would + overlap the first T'Size bytes of the record. + +  + File: gnat_rm.info, Node: Enumeration Clauses, Next: Address Clauses, Prev: Record Representation Clauses, Up: Representation Clauses and Pragmas + + Enumeration Clauses + =================== + + The only restriction on enumeration clauses is that the range of + values must be representable. For the signed case, if one or more of + the representation values are negative, all values must be in the range: + + System.Min_Int .. System.Max_Int + + For the unsigned case, where all values are non negative, the values + must be in the range: + + 0 .. System.Max_Binary_Modulus; + + A _confirming_ representation clause is one in which the values range + from 0 in sequence, i.e. a clause that confirms the default + representation for an enumeration type. Such a confirming + representation is permitted by these rules, and is specially recognized + by the compiler so that no extra overhead results from the use of such + a clause. + + If an array has an index type which is an enumeration type to which + an enumeration clause has been applied, then the array is stored in a + compact manner. Consider the declarations: + + type r is (A, B, C); + for r use (A => 1, B => 5, C => 10); + type t is array (r) of Character; + + The array type t corresponds to a vector with exactly three elements and + has a default size equal to `3*Character'Size'. This ensures efficient + use of space, but means that accesses to elements of the array will + incur the overhead of converting representation values to the + corresponding positional values, (i.e. the value delivered by the `Pos' + attribute). + +  + File: gnat_rm.info, Node: Address Clauses, Next: Effect of Convention on Representation, Prev: Enumeration Clauses, Up: Representation Clauses and Pragmas + + Address Clauses + =============== + + The reference manual allows a general restriction on representation + clauses, as found in RM 13.1(22): + + An implementation need not support representation + items containing nonstatic expressions, except that + an implementation should support a representation item + for a given entity if each nonstatic expression in the + representation item is a name that statically denotes + a constant declared before the entity. + + In practice this is applicable only to address clauses, since this is + the only case in which a non-static expression is permitted by the + syntax. As the AARM notes in sections 13.1 (22.a-22.h): + + 22.a Reason: This is to avoid the following sort + of thing: + + 22.b X : Integer := F(...); + Y : Address := G(...); + for X'Address use Y; + + 22.c In the above, we have to evaluate the + initialization expression for X before we + know where to put the result. This seems + like an unreasonable implementation burden. + + 22.d The above code should instead be written + like this: + + 22.e Y : constant Address := G(...); + X : Integer := F(...); + for X'Address use Y; + + 22.f This allows the expression ``Y'' to be safely + evaluated before X is created. + + 22.g The constant could be a formal parameter of mode in. + + 22.h An implementation can support other nonstatic + expressions if it wants to. Expressions of type + Address are hardly ever static, but their value + might be known at compile time anyway in many + cases. + + GNAT does indeed permit many additional cases of non-static + expressions. In particular, if the type involved is elementary there + are no restrictions (since in this case, holding a temporary copy of + the initialization value, if one is present, is inexpensive). In + addition, if there is no implicit or explicit initialization, then + there are no restrictions. GNAT will reject only the case where all + three of these conditions hold: + + * The type of the item is non-elementary (e.g. a record or array). + + * There is explicit or implicit initialization required for the + object. + + * The address value is non-static. Here GNAT is more permissive + than the RM, and allows the address value to be the address of a + previously declared stand-alone variable, as long as it does not + itself have an address clause. + + Anchor : Some_Initialized_Type; + Overlay : Some_Initialized_Type; + for Overlay'Address use Anchor'Address; + + However, the prefix of the address clause cannot be an array + component, or a component of a discriminated record. + + + As noted above in section 22.h, address values are typically + non-static. In particular the To_Address function, even if applied to + a literal value, is a non-static function call. To avoid this minor + annoyance, GNAT provides the implementation defined attribute + 'To_Address. The following two expressions have identical values: + + Another issue with address clauses is the interaction with alignment + requirements. When an address clause is given for an object, the + address value must be consistent with the alignment of the object + (which is usually the same as the alignment of the type of the object). + If an address clause is given that specifies an inappropriately + aligned address value, then the program execution is erroneous. + + Since this source of erroneous behavior can have unfortunate + effects, GNAT checks (at compile time if possible, generating a + warning, or at execution time with a run-time check) that the alignment + is appropriate. If the run-time check fails, then `Program_Error' is + raised. This run-time check is suppressed if range checks are + suppressed, or if `pragma Restrictions (No_Elaboration_Code)' is in + effect. + + To_Address (16#1234_0000#) + System'To_Address (16#1234_0000#); + + except that the second form is considered to be a static expression, and + thus when used as an address clause value is always permitted. + + Additionally, GNAT treats as static an address clause that is an + unchecked_conversion of a static integer value. This simplifies the + porting of legacy code, and provides a portable equivalent to the GNAT + attribute To_Address. + + An address clause cannot be given for an exported object. More + understandably the real restriction is that objects with an address + clause cannot be exported. This is because such variables are not + defined by the Ada program, so there is no external object so export. + + It is permissible to give an address clause and a pragma Import for + the same object. In this case, the variable is not really defined by + the Ada program, so there is no external symbol to be linked. The link + name and the external name are ignored in this case. The reason that + we allow this combination is that it provides a useful idiom to avoid + unwanted initializations on objects with address clauses. + + When an address clause is given for an object that has implicit or + explicit initialization, then by default initialization takes place. + This means that the effect of the object declaration is to overwrite the + memory at the specified address. This is almost always not what the + programmer wants, so GNAT will output a warning: + + with System; + package G is + type R is record + M : Integer := 0; + end record; + + Ext : R; + for Ext'Address use System'To_Address (16#1234_1234#); + | + >>> warning: implicit initialization of "Ext" may + modify overlaid storage + >>> warning: use pragma Import for "Ext" to suppress + initialization (RM B(24)) + + end G; + + As indicated by the warning message, the solution is to use a (dummy) + pragma Import to suppress this initialization. The pragma tell the + compiler that the object is declared and initialized elsewhere. The + following package compiles without warnings (and the initialization is + suppressed): + + with System; + package G is + type R is record + M : Integer := 0; + end record; + + Ext : R; + for Ext'Address use System'To_Address (16#1234_1234#); + pragma Import (Ada, Ext); + end G; + +  + File: gnat_rm.info, Node: Effect of Convention on Representation, Next: Determining the Representations chosen by GNAT, Prev: Address Clauses, Up: Representation Clauses and Pragmas + + Effect of Convention on Representation + ====================================== + + Normally the specification of a foreign language convention for a type + or an object has no effect on the chosen representation. In + particular, the representation chosen for data in GNAT generally meets + the standard system conventions, and for example records are laid out + in a manner that is consistent with C. This means that specifying + convention C (for example) has no effect. + + There are three exceptions to this general rule: + + * Convention Fortran and array subtypes If pragma Convention Fortran + is specified for an array subtype, then in accordance with the + implementation advice in section 3.6.2(11) of the Ada Reference + Manual, the array will be stored in a Fortran-compatible + column-major manner, instead of the normal default row-major order. + + * Convention C and enumeration types GNAT normally stores + enumeration types in 8, 16, or 32 bits as required to accommodate + all values of the type. For example, for the enumeration type + declared by: + + type Color is (Red, Green, Blue); + + 8 bits is sufficient to store all values of the type, so by + default, objects of type `Color' will be represented using 8 bits. + However, normal C convention is to use 32 bits for all enum + values in C, since enum values are essentially of type int. If + pragma `Convention C' is specified for an Ada enumeration type, + then the size is modified as necessary (usually to 32 bits) to be + consistent with the C convention for enum values. + + * Convention C/Fortran and Boolean types In C, the usual convention + for boolean values, that is values used for conditions, is that + zero represents false, and nonzero values represent true. In Ada, + the normal convention is that two specific values, typically 0/1, + are used to represent false/true respectively. + + Fortran has a similar convention for `LOGICAL' values (any nonzero + value represents true). + + To accommodate the Fortran and C conventions, if a pragma + Convention specifies C or Fortran convention for a derived + Boolean, as in the following example: + + type C_Switch is new Boolean; + pragma Convention (C, C_Switch); + + then the GNAT generated code will treat any nonzero value as true. + For truth values generated by GNAT, the conventional value 1 will + be used for True, but when one of these values is read, any + nonzero value is treated as True. + + +  + File: gnat_rm.info, Node: Determining the Representations chosen by GNAT, Prev: Effect of Convention on Representation, Up: Representation Clauses and Pragmas + + Determining the Representations chosen by GNAT + ============================================== + + Although the descriptions in this section are intended to be complete, + it is often easier to simply experiment to see what GNAT accepts and + what the effect is on the layout of types and objects. + + As required by the Ada RM, if a representation clause is not + accepted, then it must be rejected as illegal by the compiler. + However, when a representation clause or pragma is accepted, there can + still be questions of what the compiler actually does. For example, if + a partial record representation clause specifies the location of some + components and not others, then where are the non-specified components + placed? Or if pragma `Pack' is used on a record, then exactly where are + the resulting fields placed? The section on pragma `Pack' in this + chapter can be used to answer the second question, but it is often + easier to just see what the compiler does. + + For this purpose, GNAT provides the option `-gnatR'. If you compile + with this option, then the compiler will output information on the + actual representations chosen, in a format similar to source + representation clauses. For example, if we compile the package: + + package q is + type r (x : boolean) is tagged record + case x is + when True => S : String (1 .. 100); + when False => null; + end case; + end record; + + type r2 is new r (false) with record + y2 : integer; + end record; + + for r2 use record + y2 at 16 range 0 .. 31; + end record; + + type x is record + y : character; + end record; + + type x1 is array (1 .. 10) of x; + for x1'component_size use 11; + + type ia is access integer; + + type Rb1 is array (1 .. 13) of Boolean; + pragma Pack (rb1); + + type Rb2 is array (1 .. 65) of Boolean; + pragma Pack (rb2); + + type x2 is record + l1 : Boolean; + l2 : Duration; + l3 : Float; + l4 : Boolean; + l5 : Rb1; + l6 : Rb2; + end record; + pragma Pack (x2); + end q; + + using the switch `-gnatR' we obtain the following output: + + Representation information for unit q + ------------------------------------- + + for r'Size use ??; + for r'Alignment use 4; + for r use record + x at 4 range 0 .. 7; + _tag at 0 range 0 .. 31; + s at 5 range 0 .. 799; + end record; + + for r2'Size use 160; + for r2'Alignment use 4; + for r2 use record + x at 4 range 0 .. 7; + _tag at 0 range 0 .. 31; + _parent at 0 range 0 .. 63; + y2 at 16 range 0 .. 31; + end record; + + for x'Size use 8; + for x'Alignment use 1; + for x use record + y at 0 range 0 .. 7; + end record; + + for x1'Size use 112; + for x1'Alignment use 1; + for x1'Component_Size use 11; + + for rb1'Size use 13; + for rb1'Alignment use 2; + for rb1'Component_Size use 1; + + for rb2'Size use 72; + for rb2'Alignment use 1; + for rb2'Component_Size use 1; + + for x2'Size use 224; + for x2'Alignment use 4; + for x2 use record + l1 at 0 range 0 .. 0; + l2 at 0 range 1 .. 64; + l3 at 12 range 0 .. 31; + l4 at 16 range 0 .. 0; + l5 at 16 range 1 .. 13; + l6 at 18 range 0 .. 71; + end record; + + The Size values are actually the Object_Size, i.e. the default size that + will be allocated for objects of the type. The ?? size for type r + indicates that we have a variant record, and the actual size of objects + will depend on the discriminant value. + + The Alignment values show the actual alignment chosen by the compiler + for each record or array type. + + The record representation clause for type r shows where all fields + are placed, including the compiler generated tag field (whose location + cannot be controlled by the programmer). + + The record representation clause for the type extension r2 shows all + the fields present, including the parent field, which is a copy of the + fields of the parent type of r2, i.e. r1. + + The component size and size clauses for types rb1 and rb2 show the + exact effect of pragma `Pack' on these arrays, and the record + representation clause for type x2 shows how pragma `Pack' affects this + record type. + + In some cases, it may be useful to cut and paste the representation + clauses generated by the compiler into the original source to fix and + guarantee the actual representation to be used. + +  + File: gnat_rm.info, Node: Standard Library Routines, Next: The Implementation of Standard I/O, Prev: Representation Clauses and Pragmas, Up: Top + + Standard Library Routines + ************************* + + The Ada 95 Reference Manual contains in Annex A a full description of an + extensive set of standard library routines that can be used in any Ada + program, and which must be provided by all Ada compilers. They are + analogous to the standard C library used by C programs. + + GNAT implements all of the facilities described in annex A, and for + most purposes the description in the Ada 95 reference manual, or + appropriate Ada text book, will be sufficient for making use of these + facilities. + + In the case of the input-output facilities, *Note The Implementation + of Standard I/O::, gives details on exactly how GNAT interfaces to the + file system. For the remaining packages, the Ada 95 reference manual + should be sufficient. The following is a list of the packages included, + together with a brief description of the functionality that is provided. + + For completeness, references are included to other predefined library + routines defined in other sections of the Ada 95 reference manual + (these are cross-indexed from annex A). + + `Ada (A.2)' + This is a parent package for all the standard library packages. + It is usually included implicitly in your program, and itself + contains no useful data or routines. + + `Ada.Calendar (9.6)' + `Calendar' provides time of day access, and routines for + manipulating times and durations. + + `Ada.Characters (A.3.1)' + This is a dummy parent package that contains no useful entities + + `Ada.Characters.Handling (A.3.2)' + This package provides some basic character handling capabilities, + including classification functions for classes of characters (e.g. + test for letters, or digits). + + `Ada.Characters.Latin_1 (A.3.3)' + This package includes a complete set of definitions of the + characters that appear in type CHARACTER. It is useful for + writing programs that will run in international environments. For + example, if you want an upper case E with an acute accent in a + string, it is often better to use the definition of `UC_E_Acute' + in this package. Then your program will print in an + understandable manner even if your environment does not support + these extended characters. + + `Ada.Command_Line (A.15)' + This package provides access to the command line parameters and + the name of the current program (analogous to the use of `argc' + and `argv' in C), and also allows the exit status for the program + to be set in a system-independent manner. + + `Ada.Decimal (F.2)' + This package provides constants describing the range of decimal + numbers implemented, and also a decimal divide routine (analogous + to the COBOL verb DIVIDE .. GIVING .. REMAINDER ..) + + `Ada.Direct_IO (A.8.4)' + This package provides input-output using a model of a set of + records of fixed-length, containing an arbitrary definite Ada + type, indexed by an integer record number. + + `Ada.Dynamic_Priorities (D.5)' + This package allows the priorities of a task to be adjusted + dynamically as the task is running. + + `Ada.Exceptions (11.4.1)' + This package provides additional information on exceptions, and + also contains facilities for treating exceptions as data objects, + and raising exceptions with associated messages. + + `Ada.Finalization (7.6)' + This package contains the declarations and subprograms to support + the use of controlled types, providing for automatic + initialization and finalization (analogous to the constructors and + destructors of C++) + + `Ada.Interrupts (C.3.2)' + This package provides facilities for interfacing to interrupts, + which includes the set of signals or conditions that can be raised + and recognized as interrupts. + + `Ada.Interrupts.Names (C.3.2)' + This package provides the set of interrupt names (actually signal + or condition names) that can be handled by GNAT. + + `Ada.IO_Exceptions (A.13)' + This package defines the set of exceptions that can be raised by + use of the standard IO packages. + + `Ada.Numerics' + This package contains some standard constants and exceptions used + throughout the numerics packages. Note that the constants pi and + e are defined here, and it is better to use these definitions than + rolling your own. + + `Ada.Numerics.Complex_Elementary_Functions' + Provides the implementation of standard elementary functions (such + as log and trigonometric functions) operating on complex numbers + using the standard `Float' and the `Complex' and `Imaginary' types + created by the package `Numerics.Complex_Types'. + + `Ada.Numerics.Complex_Types' + This is a predefined instantiation of + `Numerics.Generic_Complex_Types' using `Standard.Float' to build + the type `Complex' and `Imaginary'. + + `Ada.Numerics.Discrete_Random' + This package provides a random number generator suitable for + generating random integer values from a specified range. + + `Ada.Numerics.Float_Random' + This package provides a random number generator suitable for + generating uniformly distributed floating point values. + + `Ada.Numerics.Generic_Complex_Elementary_Functions' + This is a generic version of the package that provides the + implementation of standard elementary functions (such as log and + trigonometric functions) for an arbitrary complex type. + + The following predefined instantiations of this package are + provided: + + `Short_Float' + `Ada.Numerics.Short_Complex_Elementary_Functions' + + `Float' + `Ada.Numerics.Complex_Elementary_Functions' + + `Long_Float' + `Ada.Numerics. Long_Complex_Elementary_Functions' + + `Ada.Numerics.Generic_Complex_Types' + This is a generic package that allows the creation of complex + types, with associated complex arithmetic operations. + + The following predefined instantiations of this package exist + `Short_Float' + `Ada.Numerics.Short_Complex_Complex_Types' + + `Float' + `Ada.Numerics.Complex_Complex_Types' + + `Long_Float' + `Ada.Numerics.Long_Complex_Complex_Types' + + `Ada.Numerics.Generic_Elementary_Functions' + This is a generic package that provides the implementation of + standard elementary functions (such as log an trigonometric + functions) for an arbitrary float type. + + The following predefined instantiations of this package exist + + `Short_Float' + `Ada.Numerics.Short_Elementary_Functions' + + `Float' + `Ada.Numerics.Elementary_Functions' + + `Long_Float' + `Ada.Numerics.Long_Elementary_Functions' + + `Ada.Real_Time (D.8)' + This package provides facilities similar to those of `Calendar', + but operating with a finer clock suitable for real time control. + Note that annex D requires that there be no backward clock jumps, + and GNAT generally guarantees this behavior, but of course if the + external clock on which the GNAT runtime depends is deliberately + reset by some external event, then such a backward jump may occur. + + `Ada.Sequential_IO (A.8.1)' + This package provides input-output facilities for sequential files, + which can contain a sequence of values of a single type, which can + be any Ada type, including indefinite (unconstrained) types. + + `Ada.Storage_IO (A.9)' + This package provides a facility for mapping arbitrary Ada types + to and from a storage buffer. It is primarily intended for the + creation of new IO packages. + + `Ada.Streams (13.13.1)' + This is a generic package that provides the basic support for the + concept of streams as used by the stream attributes (`Input', + `Output', `Read' and `Write'). + + `Ada.Streams.Stream_IO (A.12.1)' + This package is a specialization of the type `Streams' defined in + package `Streams' together with a set of operations providing + Stream_IO capability. The Stream_IO model permits both random and + sequential access to a file which can contain an arbitrary set of + values of one or more Ada types. + + `Ada.Strings (A.4.1)' + This package provides some basic constants used by the string + handling packages. + + `Ada.Strings.Bounded (A.4.4)' + This package provides facilities for handling variable length + strings. The bounded model requires a maximum length. It is thus + somewhat more limited than the unbounded model, but avoids the use + of dynamic allocation or finalization. + + `Ada.Strings.Fixed (A.4.3)' + This package provides facilities for handling fixed length strings. + + `Ada.Strings.Maps (A.4.2)' + This package provides facilities for handling character mappings + and arbitrarily defined subsets of characters. For instance it is + useful in defining specialized translation tables. + + `Ada.Strings.Maps.Constants (A.4.6)' + This package provides a standard set of predefined mappings and + predefined character sets. For example, the standard upper to + lower case conversion table is found in this package. Note that + upper to lower case conversion is non-trivial if you want to take + the entire set of characters, including extended characters like E + with an acute accent, into account. You should use the mappings + in this package (rather than adding 32 yourself) to do case + mappings. + + `Ada.Strings.Unbounded (A.4.5)' + This package provides facilities for handling variable length + strings. The unbounded model allows arbitrary length strings, but + requires the use of dynamic allocation and finalization. + + `Ada.Strings.Wide_Bounded (A.4.7)' + `Ada.Strings.Wide_Fixed (A.4.7)' + `Ada.Strings.Wide_Maps (A.4.7)' + `Ada.Strings.Wide_Maps.Constants (A.4.7)' + `Ada.Strings.Wide_Unbounded (A.4.7)' + These package provide analogous capabilities to the corresponding + packages without `Wide_' in the name, but operate with the types + `Wide_String' and `Wide_Character' instead of `String' and + `Character'. + + `Ada.Synchronous_Task_Control (D.10)' + This package provides some standard facilities for controlling task + communication in a synchronous manner. + + `Ada.Tags' + This package contains definitions for manipulation of the tags of + tagged values. + + `Ada.Task_Attributes' + This package provides the capability of associating arbitrary + task-specific data with separate tasks. + + `Ada.Text_IO' + This package provides basic text input-output capabilities for + character, string and numeric data. The subpackages of this + package are listed next. + + `Ada.Text_IO.Decimal_IO' + Provides input-output facilities for decimal fixed-point types + + `Ada.Text_IO.Enumeration_IO' + Provides input-output facilities for enumeration types. + + `Ada.Text_IO.Fixed_IO' + Provides input-output facilities for ordinary fixed-point types. + + `Ada.Text_IO.Float_IO' + Provides input-output facilities for float types. The following + predefined instantiations of this generic package are available: + + `Short_Float' + `Short_Float_Text_IO' + + `Float' + `Float_Text_IO' + + `Long_Float' + `Long_Float_Text_IO' + + `Ada.Text_IO.Integer_IO' + Provides input-output facilities for integer types. The following + predefined instantiations of this generic package are available: + + `Short_Short_Integer' + `Ada.Short_Short_Integer_Text_IO' + + `Short_Integer' + `Ada.Short_Integer_Text_IO' + + `Integer' + `Ada.Integer_Text_IO' + + `Long_Integer' + `Ada.Long_Integer_Text_IO' + + `Long_Long_Integer' + `Ada.Long_Long_Integer_Text_IO' + + `Ada.Text_IO.Modular_IO' + Provides input-output facilities for modular (unsigned) types + + `Ada.Text_IO.Complex_IO (G.1.3)' + This package provides basic text input-output capabilities for + complex data. + + `Ada.Text_IO.Editing (F.3.3)' + This package contains routines for edited output, analogous to the + use of pictures in COBOL. The picture formats used by this + package are a close copy of the facility in COBOL. + + `Ada.Text_IO.Text_Streams (A.12.2)' + This package provides a facility that allows Text_IO files to be + treated as streams, so that the stream attributes can be used for + writing arbitrary data, including binary data, to Text_IO files. + + `Ada.Unchecked_Conversion (13.9)' + This generic package allows arbitrary conversion from one type to + another of the same size, providing for breaking the type safety in + special circumstances. + + If the types have the same Size (more accurately the same + Value_Size), then the effect is simply to transfer the bits from + the source to the target type without any modification. This + usage is well defined, and for simple types whose representation + is typically the same across all implementations, gives a portable + method of performing such conversions. + + If the types do not have the same size, then the result is + implementation defined, and thus may be non-portable. The + following describes how GNAT handles such unchecked conversion + cases. + + If the types are of different sizes, and are both discrete types, + then the effect is of a normal type conversion without any + constraint checking. In particular if the result type has a + larger size, the result will be zero or sign extended. If the + result type has a smaller size, the result will be truncated by + ignoring high order bits. + + If the types are of different sizes, and are not both discrete + types, then the conversion works as though pointers were created + to the source and target, and the pointer value is converted. The + effect is that bits are copied from successive low order storage + units and bits of the source up to the length of the target type. + + A warning is issued if the lengths differ, since the effect in this + case is implementation dependent, and the above behavior may not + match that of some other compiler. + + A pointer to one type may be converted to a pointer to another + type using unchecked conversion. The only case in which the + effect is undefined is when one or both pointers are pointers to + unconstrained array types. In this case, the bounds information + may get incorrectly transferred, and in particular, GNAT uses + double size pointers for such types, and it is meaningless to + convert between such pointer types. GNAT will issue a warning if + the alignment of the target designated type is more strict than + the alignment of the source designated type (since the result may + be unaligned in this case). + + A pointer other than a pointer to an unconstrained array type may + be converted to and from System.Address. Such usage is common in + Ada 83 programs, but note that Ada.Address_To_Access_Conversions + is the preferred method of performing such conversions in Ada 95. + Neither unchecked conversion nor Ada.Address_To_Access_Conversions + should be used in conjunction with pointers to unconstrained + objects, since the bounds information cannot be handled correctly + in this case. + + `Ada.Unchecked_Deallocation (13.11.2)' + This generic package allows explicit freeing of storage previously + allocated by use of an allocator. + + `Ada.Wide_Text_IO (A.11)' + This package is similar to `Ada.Text_IO', except that the external + file supports wide character representations, and the internal + types are `Wide_Character' and `Wide_String' instead of `Character' + and `String'. It contains generic subpackages listed next. + + `Ada.Wide_Text_IO.Decimal_IO' + Provides input-output facilities for decimal fixed-point types + + `Ada.Wide_Text_IO.Enumeration_IO' + Provides input-output facilities for enumeration types. + + `Ada.Wide_Text_IO.Fixed_IO' + Provides input-output facilities for ordinary fixed-point types. + + `Ada.Wide_Text_IO.Float_IO' + Provides input-output facilities for float types. The following + predefined instantiations of this generic package are available: + + `Short_Float' + `Short_Float_Wide_Text_IO' + + `Float' + `Float_Wide_Text_IO' + + `Long_Float' + `Long_Float_Wide_Text_IO' + + `Ada.Wide_Text_IO.Integer_IO' + Provides input-output facilities for integer types. The following + predefined instantiations of this generic package are available: + + `Short_Short_Integer' + `Ada.Short_Short_Integer_Wide_Text_IO' + + `Short_Integer' + `Ada.Short_Integer_Wide_Text_IO' + + `Integer' + `Ada.Integer_Wide_Text_IO' + + `Long_Integer' + `Ada.Long_Integer_Wide_Text_IO' + + `Long_Long_Integer' + `Ada.Long_Long_Integer_Wide_Text_IO' + + `Ada.Wide_Text_IO.Modular_IO' + Provides input-output facilities for modular (unsigned) types + + `Ada.Wide_Text_IO.Complex_IO (G.1.3)' + This package is similar to `Ada.Text_IO.Complex_IO', except that + the external file supports wide character representations. + + `Ada.Wide_Text_IO.Editing (F.3.4)' + This package is similar to `Ada.Text_IO.Editing', except that the + types are `Wide_Character' and `Wide_String' instead of + `Character' and `String'. + + `Ada.Wide_Text_IO.Streams (A.12.3)' + This package is similar to `Ada.Text_IO.Streams', except that the + types are `Wide_Character' and `Wide_String' instead of + `Character' and `String'. + +  + File: gnat_rm.info, Node: The Implementation of Standard I/O, Next: The GNAT Library, Prev: Standard Library Routines, Up: Top + + The Implementation of Standard I/O + ********************************** + + GNAT implements all the required input-output facilities described in + A.6 through A.14. These sections of the Ada 95 reference manual + describe the required behavior of these packages from the Ada point of + view, and if you are writing a portable Ada program that does not need + to know the exact manner in which Ada maps to the outside world when it + comes to reading or writing external files, then you do not need to + read this chapter. As long as your files are all regular files (not + pipes or devices), and as long as you write and read the files only + from Ada, the description in the Ada 95 reference manual is sufficient. + + However, if you want to do input-output to pipes or other devices, + such as the keyboard or screen, or if the files you are dealing with are + either generated by some other language, or to be read by some other + language, then you need to know more about the details of how the GNAT + implementation of these input-output facilities behaves. + + In this chapter we give a detailed description of exactly how GNAT + interfaces to the file system. As always, the sources of the system are + available to you for answering questions at an even more detailed level, + but for most purposes the information in this chapter will suffice. + + Another reason that you may need to know more about how input-output + is implemented arises when you have a program written in mixed languages + where, for example, files are shared between the C and Ada sections of + the same program. GNAT provides some additional facilities, in the form + of additional child library packages, that facilitate this sharing, and + these additional facilities are also described in this chapter. + + * Menu: + + * Standard I/O Packages:: + * FORM Strings:: + * Direct_IO:: + * Sequential_IO:: + * Text_IO:: + * Wide_Text_IO:: + * Stream_IO:: + * Shared Files:: + * Open Modes:: + * Operations on C Streams:: + * Interfacing to C Streams:: + +  + File: gnat_rm.info, Node: Standard I/O Packages, Next: FORM Strings, Up: The Implementation of Standard I/O + + Standard I/O Packages + ===================== + + The Standard I/O packages described in Annex A for + + * Ada.Text_IO + + * Ada.Text_IO.Complex_IO + + * Ada.Text_IO.Text_Streams, + + * Ada.Wide_Text_IO + + * Ada.Wide_Text_IO.Complex_IO, + + * Ada.Wide_Text_IO.Text_Streams + + * Ada.Stream_IO + + * Ada.Sequential_IO + + * Ada.Direct_IO + + are implemented using the C library streams facility; where + + * All files are opened using `fopen'. + + * All input/output operations use `fread'/`fwrite'. + + There is no internal buffering of any kind at the Ada library level. + The only buffering is that provided at the system level in the + implementation of the C library routines that support streams. This + facilitates shared use of these streams by mixed language programs. + +  + File: gnat_rm.info, Node: FORM Strings, Next: Direct_IO, Prev: Standard I/O Packages, Up: The Implementation of Standard I/O + + FORM Strings + ============ + + The format of a FORM string in GNAT is: + + "keyword=value,keyword=value,...,keyword=value" + + where letters may be in upper or lower case, and there are no spaces + between values. The order of the entries is not important. Currently + there are two keywords defined. + + SHARED=[YES|NO] + WCEM=[n|h|u|s\e] + + The use of these parameters is described later in this section. + +  + File: gnat_rm.info, Node: Direct_IO, Next: Sequential_IO, Prev: FORM Strings, Up: The Implementation of Standard I/O + + Direct_IO + ========= + + Direct_IO can only be instantiated for definite types. This is a + restriction of the Ada language, which means that the records are fixed + length (the length being determined by `TYPE'Size', rounded up to the + next storage unit boundary if necessary). + + The records of a Direct_IO file are simply written to the file in + index sequence, with the first record starting at offset zero, and + subsequent records following. There is no control information of any + kind. For example, if 32-bit integers are being written, each record + takes 4-bytes, so the record at index K starts at offset (K-1)*4. + + There is no limit on the size of Direct_IO files, they are expanded + as necessary to accommodate whatever records are written to the file. + +  + File: gnat_rm.info, Node: Sequential_IO, Next: Text_IO, Prev: Direct_IO, Up: The Implementation of Standard I/O + + Sequential_IO + ============= + + Sequential_IO may be instantiated with either a definite (constrained) + or indefinite (unconstrained) type. + + For the definite type case, the elements written to the file are + simply the memory images of the data values with no control information + of any kind. The resulting file should be read using the same type, no + validity checking is performed on input. + + For the indefinite type case, the elements written consist of two + parts. First is the size of the data item, written as the memory image + of a `Interfaces.C.size_t' value, followed by the memory image of the + data value. The resulting file can only be read using the same + (unconstrained) type. Normal assignment checks are performed on these + read operations, and if these checks fail, `Data_Error' is raised. In + particular, in the array case, the lengths must match, and in the + variant record case, if the variable for a particular read operation is + constrained, the discriminants must match. + + Note that it is not possible to use Sequential_IO to write variable + length array items, and then read the data back into different length + arrays. For example, the following will raise `Data_Error': + + package IO is new Sequential_IO (String); + F : IO.File_Type; + S : String (1..4); + ... + IO.Create (F) + IO.Write (F, "hello!") + IO.Reset (F, Mode=>In_File); + IO.Read (F, S); + Put_Line (S); + + On some Ada implementations, this will print `hell', but the program + is clearly incorrect, since there is only one element in the file, and + that element is the string `hello!'. + + In Ada 95, this kind of behavior can be legitimately achieved using + Stream_IO, and this is the preferred mechanism. In particular, the + above program fragment rewritten to use Stream_IO will work correctly. + +  + File: gnat_rm.info, Node: Text_IO, Next: Wide_Text_IO, Prev: Sequential_IO, Up: The Implementation of Standard I/O + + Text_IO + ======= + + Text_IO files consist of a stream of characters containing the following + special control characters: + + LF (line feed, 16#0A#) Line Mark + FF (form feed, 16#0C#) Page Mark + + A canonical Text_IO file is defined as one in which the following + conditions are met: + + * The character `LF' is used only as a line mark, i.e. to mark the + end of the line. + + * The character `FF' is used only as a page mark, i.e. to mark the + end of a page and consequently can appear only immediately + following a `LF' (line mark) character. + + * The file ends with either `LF' (line mark) or `LF'-`FF' (line + mark, page mark). In the former case, the page mark is implicitly + assumed to be present. + + A file written using Text_IO will be in canonical form provided that + no explicit `LF' or `FF' characters are written using `Put' or + `Put_Line'. There will be no `FF' character at the end of the file + unless an explicit `New_Page' operation was performed before closing + the file. + + A canonical Text_IO file that is a regular file, i.e. not a device + or a pipe, can be read using any of the routines in Text_IO. The + semantics in this case will be exactly as defined in the Ada 95 + reference manual and all the routines in Text_IO are fully implemented. + + A text file that does not meet the requirements for a canonical + Text_IO file has one of the following: + + * The file contains `FF' characters not immediately following a `LF' + character. + + * The file contains `LF' or `FF' characters written by `Put' or + `Put_Line', which are not logically considered to be line marks or + page marks. + + * The file ends in a character other than `LF' or `FF', i.e. there + is no explicit line mark or page mark at the end of the file. + + Text_IO can be used to read such non-standard text files but + subprograms to do with line or page numbers do not have defined + meanings. In particular, a `FF' character that does not follow a `LF' + character may or may not be treated as a page mark from the point of + view of page and line numbering. Every `LF' character is considered to + end a line, and there is an implied `LF' character at the end of the + file. + + * Menu: + + * Text_IO Stream Pointer Positioning:: + * Text_IO Reading and Writing Non-Regular Files:: + * Get_Immediate:: + * Treating Text_IO Files as Streams:: + * Text_IO Extensions:: + * Text_IO Facilities for Unbounded Strings:: + +  + File: gnat_rm.info, Node: Text_IO Stream Pointer Positioning, Next: Text_IO Reading and Writing Non-Regular Files, Up: Text_IO + + Stream Pointer Positioning + -------------------------- + + `Ada.Text_IO' has a definition of current position for a file that is + being read. No internal buffering occurs in Text_IO, and usually the + physical position in the stream used to implement the file corresponds + to this logical position defined by Text_IO. There are two exceptions: + + * After a call to `End_Of_Page' that returns `True', the stream is + positioned past the `LF' (line mark) that precedes the page mark. + Text_IO maintains an internal flag so that subsequent read + operations properly handle the logical position which is unchanged + by the `End_Of_Page' call. + + * After a call to `End_Of_File' that returns `True', if the Text_IO + file was positioned before the line mark at the end of file before + the call, then the logical position is unchanged, but the stream + is physically positioned right at the end of file (past the line + mark, and past a possible page mark following the line mark. + Again Text_IO maintains internal flags so that subsequent read + operations properly handle the logical position. + + These discrepancies have no effect on the observable behavior of + Text_IO, but if a single Ada stream is shared between a C program and + Ada program, or shared (using `shared=yes' in the form string) between + two Ada files, then the difference may be observable in some situations. + +  + File: gnat_rm.info, Node: Text_IO Reading and Writing Non-Regular Files, Next: Get_Immediate, Prev: Text_IO Stream Pointer Positioning, Up: Text_IO + + Reading and Writing Non-Regular Files + ------------------------------------- + + A non-regular file is a device (such as a keyboard), or a pipe. Text_IO + can be used for reading and writing. Writing is not affected and the + sequence of characters output is identical to the normal file case, but + for reading, the behavior of Text_IO is modified to avoid undesirable + look-ahead as follows: + + An input file that is not a regular file is considered to have no + page marks. Any `Ascii.FF' characters (the character normally used for + a page mark) appearing in the file are considered to be data + characters. In particular: + + * `Get_Line' and `Skip_Line' do not test for a page mark following a + line mark. If a page mark appears, it will be treated as a data + character. + + * This avoids the need to wait for an extra character to be typed or + entered from the pipe to complete one of these operations. + + * `End_Of_Page' always returns `False' + + * `End_Of_File' will return `False' if there is a page mark at the + end of the file. + + Output to non-regular files is the same as for regular files. Page + marks may be written to non-regular files using `New_Page', but as noted + above they will not be treated as page marks on input if the output is + piped to another Ada program. + + Another important discrepancy when reading non-regular files is that + the end of file indication is not "sticky". If an end of file is + entered, e.g. by pressing the key, then end of file is signalled + once (i.e. the test `End_Of_File' will yield `True', or a read will + raise `End_Error'), but then reading can resume to read data past that + end of file indication, until another end of file indication is entered. + +  + File: gnat_rm.info, Node: Get_Immediate, Next: Treating Text_IO Files as Streams, Prev: Text_IO Reading and Writing Non-Regular Files, Up: Text_IO + + Get_Immediate + ------------- + + Get_Immediate returns the next character (including control characters) + from the input file. In particular, Get_Immediate will return LF or FF + characters used as line marks or page marks. Such operations leave the + file positioned past the control character, and it is thus not treated + as having its normal function. This means that page, line and column + counts after this kind of Get_Immediate call are set as though the mark + did not occur. In the case where a Get_Immediate leaves the file + positioned between the line mark and page mark (which is not normally + possible), it is undefined whether the FF character will be treated as a + page mark. + +  + File: gnat_rm.info, Node: Treating Text_IO Files as Streams, Next: Text_IO Extensions, Prev: Get_Immediate, Up: Text_IO + + Treating Text_IO Files as Streams + --------------------------------- + + The package `Text_IO.Streams' allows a Text_IO file to be treated as a + stream. Data written to a Text_IO file in this stream mode is binary + data. If this binary data contains bytes 16#0A# (`LF') or 16#0C# + (`FF'), the resulting file may have non-standard format. Similarly if + read operations are used to read from a Text_IO file treated as a + stream, then `LF' and `FF' characters may be skipped and the effect is + similar to that described above for `Get_Immediate'. + +  + File: gnat_rm.info, Node: Text_IO Extensions, Next: Text_IO Facilities for Unbounded Strings, Prev: Treating Text_IO Files as Streams, Up: Text_IO + + Text_IO Extensions + ------------------ + + A package GNAT.IO_Aux in the GNAT library provides some useful + extensions to the standard `Text_IO' package: + + * function File_Exists (Name : String) return Boolean; Determines if + a file of the given name exists and can be successfully opened + (without actually performing the open operation). + + * function Get_Line return String; Reads a string from the standard + input file. The value returned is exactly the length of the line + that was read. + + * function Get_Line (File : Ada.Text_IO.File_Type) return String; + Similar, except that the parameter File specifies the file from + which the string is to be read. + + +  + File: gnat_rm.info, Node: Text_IO Facilities for Unbounded Strings, Prev: Text_IO Extensions, Up: Text_IO + + Text_IO Facilities for Unbounded Strings + ---------------------------------------- + + The package `Ada.Strings.Unbounded.Text_IO' in library files + `a-suteio.ads/adb' contains some GNAT-specific subprograms useful for + Text_IO operations on unbounded strings: + + * function Get_Line (File : File_Type) return Unbounded_String; + Reads a line from the specified file and returns the result as an + unbounded string. + + * procedure Put (File : File_Type; U : Unbounded_String); Writes the + value of the given unbounded string to the specified file Similar + to the effect of `Put (To_String (U))' except that an extra copy + is avoided. + + * procedure Put_Line (File : File_Type; U : Unbounded_String); + Writes the value of the given unbounded string to the specified + file, followed by a `New_Line'. Similar to the effect of + `Put_Line (To_String (U))' except that an extra copy is avoided. + + In the above procedures, `File' is of type `Ada.Text_IO.File_Type' and + is optional. If the parameter is omitted, then the standard input or + output file is referenced as appropriate. + + The package `Ada.Strings.Wide_Unbounded.Wide_Text_IO' in library + files `a-swuwti.ads' and `a-swuwti.adb' provides similar extended + `Wide_Text_IO' functionality for unbounded wide strings. + +  + File: gnat_rm.info, Node: Wide_Text_IO, Next: Stream_IO, Prev: Text_IO, Up: The Implementation of Standard I/O + + Wide_Text_IO + ============ + + `Wide_Text_IO' is similar in most respects to Text_IO, except that both + input and output files may contain special sequences that represent + wide character values. The encoding scheme for a given file may be + specified using a FORM parameter: + + WCEM=X + + as part of the FORM string (WCEM = wide character encoding method), + where X is one of the following characters + + `h' + Hex ESC encoding + + `u' + Upper half encoding + + `s' + Shift-JIS encoding + + `e' + EUC Encoding + + `8' + UTF-8 encoding + + `b' + Brackets encoding + + The encoding methods match those that can be used in a source + program, but there is no requirement that the encoding method used for + the source program be the same as the encoding method used for files, + and different files may use different encoding methods. + + The default encoding method for the standard files, and for opened + files for which no WCEM parameter is given in the FORM string matches + the wide character encoding specified for the main program (the default + being brackets encoding if no coding method was specified with -gnatW). + + Hex Coding + In this encoding, a wide character is represented by a five + character sequence: + + ESC a b c d + + where A, B, C, D are the four hexadecimal characters (using upper + case letters) of the wide character code. For example, ESC A345 + is used to represent the wide character with code 16#A345#. This + scheme is compatible with use of the full `Wide_Character' set. + + Upper Half Coding + The wide character with encoding 16#abcd#, where the upper bit is + on (i.e. a is in the range 8-F) is represented as two bytes 16#ab# + and 16#cd#. The second byte may never be a format control + character, but is not required to be in the upper half. This + method can be also used for shift-JIS or EUC where the internal + coding matches the external coding. + + Shift JIS Coding + A wide character is represented by a two character sequence 16#ab# + and 16#cd#, with the restrictions described for upper half + encoding as described above. The internal character code is the + corresponding JIS character according to the standard algorithm + for Shift-JIS conversion. Only characters defined in the JIS code + set table can be used with this encoding method. + + EUC Coding + A wide character is represented by a two character sequence 16#ab# + and 16#cd#, with both characters being in the upper half. The + internal character code is the corresponding JIS character + according to the EUC encoding algorithm. Only characters defined + in the JIS code set table can be used with this encoding method. + + UTF-8 Coding + A wide character is represented using UCS Transformation Format 8 + (UTF-8) as defined in Annex R of ISO 10646-1/Am.2. Depending on + the character value, the representation is a one, two, or three + byte sequence: + + 16#0000#-16#007f#: 2#0xxxxxxx# + 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx# + 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# + + where the xxx bits correspond to the left-padded bits of the + 16-bit character value. Note that all lower half ASCII characters + are represented as ASCII bytes and all upper half characters and + other wide characters are represented as sequences of upper-half + (The full UTF-8 scheme allows for encoding 31-bit characters as + 6-byte sequences, but in this implementation, all UTF-8 sequences + of four or more bytes length will raise a Constraint_Error, as + will all invalid UTF-8 sequences.) + + Brackets Coding + In this encoding, a wide character is represented by the following + eight character sequence: + + [ " a b c d " ] + + Where `a', `b', `c', `d' are the four hexadecimal characters + (using uppercase letters) of the wide character code. For + example, `["A345"]' is used to represent the wide character with + code `16#A345#'. This scheme is compatible with use of the full + Wide_Character set. On input, brackets coding can also be used + for upper half characters, e.g. `["C1"]' for lower case a. + However, on output, brackets notation is only used for wide + characters with a code greater than `16#FF#'. + + For the coding schemes other than Hex and Brackets encoding, not all + wide character values can be represented. An attempt to output a + character that cannot be represented using the encoding scheme for the + file causes Constraint_Error to be raised. An invalid wide character + sequence on input also causes Constraint_Error to be raised. + + * Menu: + + * Wide_Text_IO Stream Pointer Positioning:: + * Wide_Text_IO Reading and Writing Non-Regular Files:: + +  + File: gnat_rm.info, Node: Wide_Text_IO Stream Pointer Positioning, Next: Wide_Text_IO Reading and Writing Non-Regular Files, Up: Wide_Text_IO + + Stream Pointer Positioning + -------------------------- + + `Ada.Wide_Text_IO' is similar to `Ada.Text_IO' in its handling of + stream pointer positioning (*note Text_IO::). There is one additional + case: + + If `Ada.Wide_Text_IO.Look_Ahead' reads a character outside the + normal lower ASCII set (i.e. a character in the range: + + Wide_Character'Val (16#0080#) .. Wide_Character'Val (16#FFFF#) + + then although the logical position of the file pointer is unchanged by + the `Look_Ahead' call, the stream is physically positioned past the + wide character sequence. Again this is to avoid the need for buffering + or backup, and all `Wide_Text_IO' routines check the internal + indication that this situation has occurred so that this is not visible + to a normal program using `Wide_Text_IO'. However, this discrepancy + can be observed if the wide text file shares a stream with another file. + +  + File: gnat_rm.info, Node: Wide_Text_IO Reading and Writing Non-Regular Files, Prev: Wide_Text_IO Stream Pointer Positioning, Up: Wide_Text_IO + + Reading and Writing Non-Regular Files + ------------------------------------- + + As in the case of Text_IO, when a non-regular file is read, it is + assumed that the file contains no page marks (any form characters are + treated as data characters), and `End_Of_Page' always returns `False'. + Similarly, the end of file indication is not sticky, so it is possible + to read beyond an end of file. + +  + File: gnat_rm.info, Node: Stream_IO, Next: Shared Files, Prev: Wide_Text_IO, Up: The Implementation of Standard I/O + + Stream_IO + ========= + + A stream file is a sequence of bytes, where individual elements are + written to the file as described in the Ada 95 reference manual. The + type `Stream_Element' is simply a byte. There are two ways to read or + write a stream file. + + * The operations `Read' and `Write' directly read or write a + sequence of stream elements with no control information. + + * The stream attributes applied to a stream file transfer data in the + manner described for stream attributes. + +  + File: gnat_rm.info, Node: Shared Files, Next: Open Modes, Prev: Stream_IO, Up: The Implementation of Standard I/O + + Shared Files + ============ + + Section A.14 of the Ada 95 Reference Manual allows implementations to + provide a wide variety of behavior if an attempt is made to access the + same external file with two or more internal files. + + To provide a full range of functionality, while at the same time + minimizing the problems of portability caused by this implementation + dependence, GNAT handles file sharing as follows: + + * In the absence of a `shared=XXX' form parameter, an attempt to + open two or more files with the same full name is considered an + error and is not supported. The exception `Use_Error' will be + raised. Note that a file that is not explicitly closed by the + program remains open until the program terminates. + + * If the form parameter `shared=no' appears in the form string, the + file can be opened or created with its own separate stream + identifier, regardless of whether other files sharing the same + external file are opened. The exact effect depends on how the C + stream routines handle multiple accesses to the same external + files using separate streams. + + * If the form parameter `shared=yes' appears in the form string for + each of two or more files opened using the same full name, the same + stream is shared between these files, and the semantics are as + described in Ada 95 Reference Manual, Section A.14. + + When a program that opens multiple files with the same name is ported + from another Ada compiler to GNAT, the effect will be that `Use_Error' + is raised. + + The documentation of the original compiler and the documentation of + the program should then be examined to determine if file sharing was + expected, and `shared=XXX' parameters added to `Open' and `Create' + calls as required. + + When a program is ported from GNAT to some other Ada compiler, no + special attention is required unless the `shared=XXX' form parameter is + used in the program. In this case, you must examine the documentation + of the new compiler to see if it supports the required file sharing + semantics, and form strings modified appropriately. Of course it may + be the case that the program cannot be ported if the target compiler + does not support the required functionality. The best approach in + writing portable code is to avoid file sharing (and hence the use of + the `shared=XXX' parameter in the form string) completely. + + One common use of file sharing in Ada 83 is the use of + instantiations of Sequential_IO on the same file with different types, + to achieve heterogeneous input-output. Although this approach will + work in GNAT if `shared=yes' is specified, it is preferable in Ada 95 + to use Stream_IO for this purpose (using the stream attributes) + +  + File: gnat_rm.info, Node: Open Modes, Next: Operations on C Streams, Prev: Shared Files, Up: The Implementation of Standard I/O + + Open Modes + ========== + + `Open' and `Create' calls result in a call to `fopen' using the mode + shown in Table 6.1 + + + + Table 6-1 `Open' and `Create' Call Modes + OPEN CREATE + Append_File "r+" "w+" + In_File "r" "w+" + Out_File (Direct_IO) "r+" "w" + Out_File (all other cases) "w" "w" + Inout_File "r+" "w+" + + If text file translation is required, then either `b' or `t' is + added to the mode, depending on the setting of Text. Text file + translation refers to the mapping of CR/LF sequences in an external file + to LF characters internally. This mapping only occurs in DOS and + DOS-like systems, and is not relevant to other systems. + + A special case occurs with Stream_IO. As shown in the above table, + the file is initially opened in `r' or `w' mode for the `In_File' and + `Out_File' cases. If a `Set_Mode' operation subsequently requires + switching from reading to writing or vice-versa, then the file is + reopened in `r+' mode to permit the required operation. + +  + File: gnat_rm.info, Node: Operations on C Streams, Next: Interfacing to C Streams, Prev: Open Modes, Up: The Implementation of Standard I/O + + Operations on C Streams + ======================= + + The package `Interfaces.C_Streams' provides an Ada program with + direct access to the C library functions for operations on C streams: + + package Interfaces.C_Streams is + -- Note: the reason we do not use the types that are in + -- Interfaces.C is that we want to avoid dragging in the + -- code in this unit if possible. + subtype chars is System.Address; + -- Pointer to null-terminated array of characters + subtype FILEs is System.Address; + -- Corresponds to the C type FILE* + subtype voids is System.Address; + -- Corresponds to the C type void* + subtype int is Integer; + subtype long is Long_Integer; + -- Note: the above types are subtypes deliberately, and it + -- is part of this spec that the above correspondences are + -- guaranteed. This means that it is legitimate to, for + -- example, use Integer instead of int. We provide these + -- synonyms for clarity, but in some cases it may be + -- convenient to use the underlying types (for example to + -- avoid an unnecessary dependency of a spec on the spec + -- of this unit). + type size_t is mod 2 ** Standard'Address_Size; + NULL_Stream : constant FILEs; + -- Value returned (NULL in C) to indicate an + -- fdopen/fopen/tmpfile error + ---------------------------------- + -- Constants Defined in stdio.h -- + ---------------------------------- + EOF : constant int; + -- Used by a number of routines to indicate error or + -- end of file + IOFBF : constant int; + IOLBF : constant int; + IONBF : constant int; + -- Used to indicate buffering mode for setvbuf call + SEEK_CUR : constant int; + SEEK_END : constant int; + SEEK_SET : constant int; + -- Used to indicate origin for fseek call + function stdin return FILEs; + function stdout return FILEs; + function stderr return FILEs; + -- Streams associated with standard files + -------------------------- + -- Standard C functions -- + -------------------------- + -- The functions selected below are ones that are + -- available in DOS, OS/2, UNIX and Xenix (but not + -- necessarily in ANSI C). These are very thin interfaces + -- which copy exactly the C headers. For more + -- documentation on these functions, see the Microsoft C + -- "Run-Time Library Reference" (Microsoft Press, 1990, + -- ISBN 1-55615-225-6), which includes useful information + -- on system compatibility. + procedure clearerr (stream : FILEs); + function fclose (stream : FILEs) return int; + function fdopen (handle : int; mode : chars) return FILEs; + function feof (stream : FILEs) return int; + function ferror (stream : FILEs) return int; + function fflush (stream : FILEs) return int; + function fgetc (stream : FILEs) return int; + function fgets (strng : chars; n : int; stream : FILEs) + return chars; + function fileno (stream : FILEs) return int; + function fopen (filename : chars; Mode : chars) + return FILEs; + -- Note: to maintain target independence, use + -- text_translation_required, a boolean variable defined in + -- a-sysdep.c to deal with the target dependent text + -- translation requirement. If this variable is set, + -- then b/t should be appended to the standard mode + -- argument to set the text translation mode off or on + -- as required. + function fputc (C : int; stream : FILEs) return int; + function fputs (Strng : chars; Stream : FILEs) return int; + function fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + function freopen + (filename : chars; + mode : chars; + stream : FILEs) + return FILEs; + function fseek + (stream : FILEs; + offset : long; + origin : int) + return int; + function ftell (stream : FILEs) return long; + function fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + function isatty (handle : int) return int; + procedure mktemp (template : chars); + -- The return value (which is just a pointer to template) + -- is discarded + procedure rewind (stream : FILEs); + function rmtmp return int; + function setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) + return int; + + function tmpfile return FILEs; + function ungetc (c : int; stream : FILEs) return int; + function unlink (filename : chars) return int; + --------------------- + -- Extra functions -- + --------------------- + -- These functions supply slightly thicker bindings than + -- those above. They are derived from functions in the + -- C Run-Time Library, but may do a bit more work than + -- just directly calling one of the Library functions. + function is_regular_file (handle : int) return int; + -- Tests if given handle is for a regular file (result 1) + -- or for a non-regular file (pipe or device, result 0). + --------------------------------- + -- Control of Text/Binary Mode -- + --------------------------------- + -- If text_translation_required is true, then the following + -- functions may be used to dynamically switch a file from + -- binary to text mode or vice versa. These functions have + -- no effect if text_translation_required is false (i.e. in + -- normal UNIX mode). Use fileno to get a stream handle. + procedure set_binary_mode (handle : int); + procedure set_text_mode (handle : int); + ---------------------------- + -- Full Path Name support -- + ---------------------------- + procedure full_name (nam : chars; buffer : chars); + -- Given a NUL terminated string representing a file + -- name, returns in buffer a NUL terminated string + -- representing the full path name for the file name. + -- On systems where it is relevant the drive is also + -- part of the full path name. It is the responsibility + -- of the caller to pass an actual parameter for buffer + -- that is big enough for any full path name. Use + -- max_path_len given below as the size of buffer. + max_path_len : integer; + -- Maximum length of an allowable full path name on the + -- system, including a terminating NUL character. + end Interfaces.C_Streams; + +  + File: gnat_rm.info, Node: Interfacing to C Streams, Prev: Operations on C Streams, Up: The Implementation of Standard I/O + + Interfacing to C Streams + ======================== + + The packages in this section permit interfacing Ada files to C Stream + operations. + + with Interfaces.C_Streams; + package Ada.Sequential_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Sequential_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Direct_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Direct_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Text_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Text_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Wide_Text_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Wide_Text_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Stream_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Stream_IO.C_Streams; + + In each of these five packages, the `C_Stream' function obtains the + `FILE' pointer from a currently opened Ada file. It is then possible + to use the `Interfaces.C_Streams' package to operate on this stream, or + the stream can be passed to a C program which can operate on it + directly. Of course the program is responsible for ensuring that only + appropriate sequences of operations are executed. + + One particular use of relevance to an Ada program is that the + `setvbuf' function can be used to control the buffering of the stream + used by an Ada file. In the absence of such a call the standard + default buffering is used. + + The `Open' procedures in these packages open a file giving an + existing C Stream instead of a file name. Typically this stream is + imported from a C program, allowing an Ada file to operate on an + existing C file. + +  + File: gnat_rm.info, Node: The GNAT Library, Next: Interfacing to Other Languages, Prev: The Implementation of Standard I/O, Up: Top + + The GNAT Library + **************** + + The GNAT library contains a number of general and special purpose + packages. It represents functionality that the GNAT developers have + found useful, and which is made available to GNAT users. The packages + described here are fully supported, and upwards compatibility will be + maintained in future releases, so you can use these facilities with the + confidence that the same functionality will be available in future + releases. + + The chapter here simply gives a brief summary of the facilities + available. The full documentation is found in the spec file for the + package. The full sources of these library packages, including both + spec and body, are provided with all GNAT releases. For example, to + find out the full specifications of the SPITBOL pattern matching + capability, including a full tutorial and extensive examples, look in + the `g-spipat.ads' file in the library. + + For each entry here, the package name (as it would appear in a `with' + clause) is given, followed by the name of the corresponding spec file in + parentheses. The packages are children in four hierarchies, `Ada', + `Interfaces', `System', and `GNAT', the latter being a GNAT-specific + hierarchy. + + Note that an application program should only use packages in one of + these four hierarchies if the package is defined in the Ada Reference + Manual, or is listed in this section of the GNAT Programmers Reference + Manual. All other units should be considered internal implementation + units and should not be directly `with''ed by application code. The + use of a `with' statement that references one of these internal + implementation units makes an application potentially dependent on + changes in versions of GNAT, and will generate a warning message. + + * Menu: + + * Ada.Characters.Latin_9 (a-chlat9.ads):: + * Ada.Characters.Wide_Latin_1 (a-cwila1.ads):: + * Ada.Characters.Wide_Latin_9 (a-cwila9.ads):: + * Ada.Command_Line.Remove (a-colire.ads):: + * Ada.Direct_IO.C_Streams (a-diocst.ads):: + * Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads):: + * Ada.Sequential_IO.C_Streams (a-siocst.ads):: + * Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads):: + * Ada.Strings.Unbounded.Text_IO (a-suteio.ads):: + * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: + * Ada.Text_IO.C_Streams (a-tiocst.ads):: + * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: + * GNAT.AWK (g-awk.ads):: + * GNAT.Bubble_Sort_A (g-busora.ads):: + * GNAT.Bubble_Sort_G (g-busorg.ads):: + * GNAT.Calendar (g-calend.ads):: + * GNAT.Calendar.Time_IO (g-catiio.ads):: + * GNAT.CRC32 (g-crc32.ads):: + * GNAT.Case_Util (g-casuti.ads):: + * GNAT.CGI (g-cgi.ads):: + * GNAT.CGI.Cookie (g-cgicoo.ads):: + * GNAT.CGI.Debug (g-cgideb.ads):: + * GNAT.Command_Line (g-comlin.ads):: + * GNAT.Current_Exception (g-curexc.ads):: + * GNAT.Debug_Pools (g-debpoo.ads):: + * GNAT.Debug_Utilities (g-debuti.ads):: + * GNAT.Directory_Operations (g-dirope.ads):: + * GNAT.Dynamic_Tables (g-dyntab.ads):: + * GNAT.Exception_Traces (g-exctra.ads):: + * GNAT.Expect (g-expect.ads):: + * GNAT.Float_Control (g-flocon.ads):: + * GNAT.Heap_Sort_A (g-hesora.ads):: + * GNAT.Heap_Sort_G (g-hesorg.ads):: + * GNAT.HTable (g-htable.ads):: + * GNAT.IO (g-io.ads):: + * GNAT.IO_Aux (g-io_aux.ads):: + * GNAT.Lock_Files (g-locfil.ads):: + * GNAT.MD5 (g-md5.ads):: + * GNAT.Most_Recent_Exception (g-moreex.ads):: + * GNAT.OS_Lib (g-os_lib.ads):: + * GNAT.Regexp (g-regexp.ads):: + * GNAT.Registry (g-regist.ads):: + * GNAT.Regpat (g-regpat.ads):: + * GNAT.Sockets (g-socket.ads):: + * GNAT.Source_Info (g-souinf.ads):: + * GNAT.Spell_Checker (g-speche.ads):: + * GNAT.Spitbol.Patterns (g-spipat.ads):: + * GNAT.Spitbol (g-spitbo.ads):: + * GNAT.Spitbol.Table_Boolean (g-sptabo.ads):: + * GNAT.Spitbol.Table_Integer (g-sptain.ads):: + * GNAT.Spitbol.Table_VString (g-sptavs.ads):: + * GNAT.Table (g-table.ads):: + * GNAT.Task_Lock (g-tasloc.ads):: + * GNAT.Threads (g-thread.ads):: + * GNAT.Traceback (g-traceb.ads):: + * GNAT.Traceback.Symbolic (g-trasym.ads):: + * Interfaces.C.Extensions (i-cexten.ads):: + * Interfaces.C.Streams (i-cstrea.ads):: + * Interfaces.CPP (i-cpp.ads):: + * Interfaces.Os2lib (i-os2lib.ads):: + * Interfaces.Os2lib.Errors (i-os2err.ads):: + * Interfaces.Os2lib.Synchronization (i-os2syn.ads):: + * Interfaces.Os2lib.Threads (i-os2thr.ads):: + * Interfaces.Packed_Decimal (i-pacdec.ads):: + * Interfaces.VxWorks (i-vxwork.ads):: + * Interfaces.VxWorks.IO (i-vxwoio.ads):: + * System.Address_Image (s-addima.ads):: + * System.Assertions (s-assert.ads):: + * System.Partition_Interface (s-parint.ads):: + * System.Task_Info (s-tasinf.ads):: + * System.Wch_Cnv (s-wchcnv.ads):: + * System.Wch_Con (s-wchcon.ads):: + +  + File: gnat_rm.info, Node: Ada.Characters.Latin_9 (a-chlat9.ads), Next: Ada.Characters.Wide_Latin_1 (a-cwila1.ads), Up: The GNAT Library + + `Ada.Characters.Latin_9' (`a-chlat9.ads') + ========================================= + + This child of `Ada.Characters' provides a set of definitions + corresponding to those in the RM-defined package + `Ada.Characters.Latin_1' but with the few modifications required for + `Latin-9' The provision of such a package is specifically authorized by + the Ada Reference Manual (RM A.3(27)). + +  + File: gnat_rm.info, Node: Ada.Characters.Wide_Latin_1 (a-cwila1.ads), Next: Ada.Characters.Wide_Latin_9 (a-cwila9.ads), Prev: Ada.Characters.Latin_9 (a-chlat9.ads), Up: The GNAT Library + + `Ada.Characters.Wide_Latin_1' (`a-cwila1.ads') + ============================================== + + This child of `Ada.Characters' provides a set of definitions + corresponding to those in the RM-defined package + `Ada.Characters.Latin_1' but with the types of the constants being + `Wide_Character' instead of `Character'. The provision of such a + package is specifically authorized by the Ada Reference Manual (RM + A.3(27)). + +  + File: gnat_rm.info, Node: Ada.Characters.Wide_Latin_9 (a-cwila9.ads), Next: Ada.Command_Line.Remove (a-colire.ads), Prev: Ada.Characters.Wide_Latin_1 (a-cwila1.ads), Up: The GNAT Library + + `Ada.Characters.Wide_Latin_9' (`a-cwila1.ads') + ============================================== + + This child of `Ada.Characters' provides a set of definitions + corresponding to those in the GNAT defined package + `Ada.Characters.Latin_9' but with the types of the constants being + `Wide_Character' instead of `Character'. The provision of such a + package is specifically authorized by the Ada Reference Manual (RM + A.3(27)). + +  + File: gnat_rm.info, Node: Ada.Command_Line.Remove (a-colire.ads), Next: Ada.Direct_IO.C_Streams (a-diocst.ads), Prev: Ada.Characters.Wide_Latin_9 (a-cwila9.ads), Up: The GNAT Library + + `Ada.Command_Line.Remove' (`a-colire.ads') + ========================================== + + This child of `Ada.Command_Line' provides a mechanism for logically + removing arguments from the argument list. Once removed, an argument + is not visible to further calls on the subprograms in + `Ada.Command_Line' will not see the removed argument. + +  + File: gnat_rm.info, Node: Ada.Direct_IO.C_Streams (a-diocst.ads), Next: Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads), Prev: Ada.Command_Line.Remove (a-colire.ads), Up: The GNAT Library + + `Ada.Direct_IO.C_Streams' (`a-diocst.ads') + ========================================== + + This package provides subprograms that allow interfacing between C + streams and `Direct_IO'. The stream identifier can be extracted from a + file opened on the Ada side, and an Ada file can be constructed from a + stream opened on the C side. + +  + File: gnat_rm.info, Node: Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads), Next: Ada.Sequential_IO.C_Streams (a-siocst.ads), Prev: Ada.Direct_IO.C_Streams (a-diocst.ads), Up: The GNAT Library + + `Ada.Exceptions.Is_Null_Occurrence' (`a-einuoc.ads') + ==================================================== + + This child subprogram provides a way of testing for the null exception + occurrence (`Null_Occurrence') without raising an exception. + +  + File: gnat_rm.info, Node: Ada.Sequential_IO.C_Streams (a-siocst.ads), Next: Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads), Prev: Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads), Up: The GNAT Library + + `Ada.Sequential_IO.C_Streams' (`a-siocst.ads') + ============================================== + + This package provides subprograms that allow interfacing between C + streams and `Sequential_IO'. The stream identifier can be extracted + from a file opened on the Ada side, and an Ada file can be constructed + from a stream opened on the C side. + +  + File: gnat_rm.info, Node: Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads), Next: Ada.Strings.Unbounded.Text_IO (a-suteio.ads), Prev: Ada.Sequential_IO.C_Streams (a-siocst.ads), Up: The GNAT Library + + `Ada.Streams.Stream_IO.C_Streams' (`a-ssicst.ads') + ================================================== + + This package provides subprograms that allow interfacing between C + streams and `Stream_IO'. The stream identifier can be extracted from a + file opened on the Ada side, and an Ada file can be constructed from a + stream opened on the C side. + +  + File: gnat_rm.info, Node: Ada.Strings.Unbounded.Text_IO (a-suteio.ads), Next: Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads), Prev: Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads), Up: The GNAT Library + + `Ada.Strings.Unbounded.Text_IO' (`a-suteio.ads') + ================================================ + + This package provides subprograms for Text_IO for unbounded strings, + avoiding the necessity for an intermediate operation with ordinary + strings. + +  + File: gnat_rm.info, Node: Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads), Next: Ada.Text_IO.C_Streams (a-tiocst.ads), Prev: Ada.Strings.Unbounded.Text_IO (a-suteio.ads), Up: The GNAT Library + + `Ada.Strings.Wide_Unbounded.Wide_Text_IO' (`a-swuwti.ads') + ========================================================== + + This package provides subprograms for Text_IO for unbounded wide + strings, avoiding the necessity for an intermediate operation with + ordinary wide strings. + +  + File: gnat_rm.info, Node: Ada.Text_IO.C_Streams (a-tiocst.ads), Next: Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads), Prev: Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads), Up: The GNAT Library + + `Ada.Text_IO.C_Streams' (`a-tiocst.ads') + ======================================== + + This package provides subprograms that allow interfacing between C + streams and `Text_IO'. The stream identifier can be extracted from a + file opened on the Ada side, and an Ada file can be constructed from a + stream opened on the C side. + +  + File: gnat_rm.info, Node: Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads), Next: GNAT.AWK (g-awk.ads), Prev: Ada.Text_IO.C_Streams (a-tiocst.ads), Up: The GNAT Library + + `Ada.Wide_Text_IO.C_Streams' (`a-wtcstr.ads') + ============================================= + + This package provides subprograms that allow interfacing between C + streams and `Wide_Text_IO'. The stream identifier can be extracted + from a file opened on the Ada side, and an Ada file can be constructed + from a stream opened on the C side. + +  + File: gnat_rm.info, Node: GNAT.AWK (g-awk.ads), Next: GNAT.Bubble_Sort_A (g-busora.ads), Prev: Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads), Up: The GNAT Library + + `GNAT.AWK' (`g-awk.ads') + ======================== + + Provides AWK-like parsing functions, with an easy interface for parsing + one or more files containing formatted data. The file is viewed as a + database where each record is a line and a field is a data element in + this line. + +  + File: gnat_rm.info, Node: GNAT.Bubble_Sort_A (g-busora.ads), Next: GNAT.Bubble_Sort_G (g-busorg.ads), Prev: GNAT.AWK (g-awk.ads), Up: The GNAT Library + + `GNAT.Bubble_Sort_A' (`g-busora.ads') + ===================================== + + Provides a general implementation of bubble sort usable for sorting + arbitrary data items. Move and comparison procedures are provided by + passing access-to-procedure values. + +  + File: gnat_rm.info, Node: GNAT.Bubble_Sort_G (g-busorg.ads), Next: GNAT.Calendar (g-calend.ads), Prev: GNAT.Bubble_Sort_A (g-busora.ads), Up: The GNAT Library + + `GNAT.Bubble_Sort_G' (`g-busorg.ads') + ===================================== + + Similar to `Bubble_Sort_A' except that the move and sorting procedures + are provided as generic parameters, this improves efficiency, especially + if the procedures can be inlined, at the expense of duplicating code for + multiple instantiations. + +  + File: gnat_rm.info, Node: GNAT.Calendar (g-calend.ads), Next: GNAT.Calendar.Time_IO (g-catiio.ads), Prev: GNAT.Bubble_Sort_G (g-busorg.ads), Up: The GNAT Library + + `GNAT.Calendar' (`g-calend.ads') + ================================ + + Extends the facilities provided by `Ada.Calendar' to include handling + of days of the week, an extended `Split' and `Time_Of' capability. + Also provides conversion of `Ada.Calendar.Time' values to and from the + C `timeval' format. + +  + File: gnat_rm.info, Node: GNAT.Calendar.Time_IO (g-catiio.ads), Next: GNAT.CRC32 (g-crc32.ads), Prev: GNAT.Calendar (g-calend.ads), Up: The GNAT Library + + `GNAT.Calendar.Time_IO' (`g-catiio.ads') + ======================================== + +  + File: gnat_rm.info, Node: GNAT.CRC32 (g-crc32.ads), Next: GNAT.Case_Util (g-casuti.ads), Prev: GNAT.Calendar.Time_IO (g-catiio.ads), Up: The GNAT Library + + `GNAT.CRC32' (`g-crc32.ads') + ============================ + + This package implements the CRC-32 algorithm. For a full description + of this algorithm you should have a look at: "Computation of Cyclic + Redundancy Checks via Table Look-Up", `Communications of the ACM', Vol. + 31 No. 8, pp. 1008-1013, Aug. 1988. Sarwate, D.V. + + Provides an extended capability for formatted output of time values with + full user control over the format. Modeled on the GNU Date + specification. + +  + File: gnat_rm.info, Node: GNAT.Case_Util (g-casuti.ads), Next: GNAT.CGI (g-cgi.ads), Prev: GNAT.CRC32 (g-crc32.ads), Up: The GNAT Library + + `GNAT.Case_Util' (`g-casuti.ads') + ================================= + + A set of simple routines for handling upper and lower casing of strings + without the overhead of the full casing tables in + `Ada.Characters.Handling'. + +  + File: gnat_rm.info, Node: GNAT.CGI (g-cgi.ads), Next: GNAT.CGI.Cookie (g-cgicoo.ads), Prev: GNAT.Case_Util (g-casuti.ads), Up: The GNAT Library + + `GNAT.CGI' (`g-cgi.ads') + ======================== + + This is a package for interfacing a GNAT program with a Web server via + the Common Gateway Interface (CGI). Basically this package parses the + CGI parameters, which are a set of key/value pairs sent by the Web + server. It builds a table whose index is the key and provides some + services to deal with this table. + +  + File: gnat_rm.info, Node: GNAT.CGI.Cookie (g-cgicoo.ads), Next: GNAT.CGI.Debug (g-cgideb.ads), Prev: GNAT.CGI (g-cgi.ads), Up: The GNAT Library + + `GNAT.CGI.Cookie' (`g-cgicoo.ads') + ================================== + + This is a package to interface a GNAT program with a Web server via the + Common Gateway Interface (CGI). It exports services to deal with Web + cookies (piece of information kept in the Web client software). + +  + File: gnat_rm.info, Node: GNAT.CGI.Debug (g-cgideb.ads), Next: GNAT.Command_Line (g-comlin.ads), Prev: GNAT.CGI.Cookie (g-cgicoo.ads), Up: The GNAT Library + + `GNAT.CGI.Debug' (`g-cgideb.ads') + ================================= + + This is a package to help debugging CGI (Common Gateway Interface) + programs written in Ada. + +  + File: gnat_rm.info, Node: GNAT.Command_Line (g-comlin.ads), Next: GNAT.Current_Exception (g-curexc.ads), Prev: GNAT.CGI.Debug (g-cgideb.ads), Up: The GNAT Library + + `GNAT.Command_Line' (`g-comlin.ads') + ==================================== + + Provides a high level interface to `Ada.Command_Line' facilities, + including the ability to scan for named switches with optional + parameters and expand file names using wild card notations. + +  + File: gnat_rm.info, Node: GNAT.Current_Exception (g-curexc.ads), Next: GNAT.Debug_Pools (g-debpoo.ads), Prev: GNAT.Command_Line (g-comlin.ads), Up: The GNAT Library + + `GNAT.Current_Exception' (`g-curexc.ads') + ========================================= + + Provides access to information on the current exception that has been + raised without the need for using the Ada-95 exception choice parameter + specification syntax. This is particularly useful in simulating + typical facilities for obtaining information about exceptions provided + by Ada 83 compilers. + +  + File: gnat_rm.info, Node: GNAT.Debug_Pools (g-debpoo.ads), Next: GNAT.Debug_Utilities (g-debuti.ads), Prev: GNAT.Current_Exception (g-curexc.ads), Up: The GNAT Library + + `GNAT.Debug_Pools' (`g-debpoo.ads') + =================================== + + Provide a debugging storage pools that helps tracking memory corruption + problems. See section "Finding memory problems with GNAT Debug Pool" in + the `GNAT User's Guide'. + +  + File: gnat_rm.info, Node: GNAT.Debug_Utilities (g-debuti.ads), Next: GNAT.Directory_Operations (g-dirope.ads), Prev: GNAT.Debug_Pools (g-debpoo.ads), Up: The GNAT Library + + `GNAT.Debug_Utilities' (`g-debuti.ads') + ======================================= + + Provides a few useful utilities for debugging purposes, including + conversion to and from string images of address values. + +  + File: gnat_rm.info, Node: GNAT.Directory_Operations (g-dirope.ads), Next: GNAT.Dynamic_Tables (g-dyntab.ads), Prev: GNAT.Debug_Utilities (g-debuti.ads), Up: The GNAT Library + + `GNAT.Directory_Operations' (g-dirope.ads) + ========================================== + + Provides a set of routines for manipulating directories, including + changing the current directory, making new directories, and scanning + the files in a directory. + +  + File: gnat_rm.info, Node: GNAT.Dynamic_Tables (g-dyntab.ads), Next: GNAT.Exception_Traces (g-exctra.ads), Prev: GNAT.Directory_Operations (g-dirope.ads), Up: The GNAT Library + + `GNAT.Dynamic_Tables' (`g-dyntab.ads') + ====================================== + + A generic package providing a single dimension array abstraction where + the length of the array can be dynamically modified. + + This package provides a facility similar to that of GNAT.Table, except + that this package declares a type that can be used to define dynamic + instances of the table, while an instantiation of GNAT.Table creates a + single instance of the table type. + +  + File: gnat_rm.info, Node: GNAT.Exception_Traces (g-exctra.ads), Next: GNAT.Expect (g-expect.ads), Prev: GNAT.Dynamic_Tables (g-dyntab.ads), Up: The GNAT Library + + `GNAT.Exception_Traces' (`g-exctra.ads') + ======================================== + + Provides an interface allowing to control automatic output upon + exception occurrences. + +  + File: gnat_rm.info, Node: GNAT.Expect (g-expect.ads), Next: GNAT.Float_Control (g-flocon.ads), Prev: GNAT.Exception_Traces (g-exctra.ads), Up: The GNAT Library + + `GNAT.Expect' (`g-expect.ads') + ============================== + + Provides a set of subprograms similar to what is available with the + standard Tcl Expect tool. It allows you to easily spawn and + communicate with an external process. You can send commands or inputs + to the process, and compare the output with some expected regular + expression. Currently GNAT.Expect is implemented on all native GNAT + ports except for OpenVMS. It is not implemented for cross ports, and + in particular is not implemented for VxWorks or LynxOS. + +  + File: gnat_rm.info, Node: GNAT.Float_Control (g-flocon.ads), Next: GNAT.Heap_Sort_A (g-hesora.ads), Prev: GNAT.Expect (g-expect.ads), Up: The GNAT Library + + `GNAT.Float_Control' (`g-flocon.ads') + ===================================== + + Provides an interface for resetting the floating-point processor into + the mode required for correct semantic operation in Ada. Some third + party library calls may cause this mode to be modified, and the Reset + procedure in this package can be used to reestablish the required mode. + +  + File: gnat_rm.info, Node: GNAT.Heap_Sort_A (g-hesora.ads), Next: GNAT.Heap_Sort_G (g-hesorg.ads), Prev: GNAT.Float_Control (g-flocon.ads), Up: The GNAT Library + + `GNAT.Heap_Sort_A' (`g-hesora.ads') + =================================== + + Provides a general implementation of heap sort usable for sorting + arbitrary data items. Move and comparison procedures are provided by + passing access-to-procedure values. The algorithm used is a modified + heap sort that performs approximately N*log(N) comparisons in the worst + case. + +  + File: gnat_rm.info, Node: GNAT.Heap_Sort_G (g-hesorg.ads), Next: GNAT.HTable (g-htable.ads), Prev: GNAT.Heap_Sort_A (g-hesora.ads), Up: The GNAT Library + + `GNAT.Heap_Sort_G' (`g-hesorg.ads') + =================================== + + Similar to `Heap_Sort_A' except that the move and sorting procedures + are provided as generic parameters, this improves efficiency, especially + if the procedures can be inlined, at the expense of duplicating code for + multiple instantiations. + +  + File: gnat_rm.info, Node: GNAT.HTable (g-htable.ads), Next: GNAT.IO (g-io.ads), Prev: GNAT.Heap_Sort_G (g-hesorg.ads), Up: The GNAT Library + + `GNAT.HTable' (`g-htable.ads') + ============================== + + A generic implementation of hash tables that can be used to hash + arbitrary data. Provides two approaches, one a simple static approach, + and the other allowing arbitrary dynamic hash tables. + +  + File: gnat_rm.info, Node: GNAT.IO (g-io.ads), Next: GNAT.IO_Aux (g-io_aux.ads), Prev: GNAT.HTable (g-htable.ads), Up: The GNAT Library + + `GNAT.IO' (`g-io.ads') + ====================== + + A simple preealborable input-output package that provides a subset of + simple Text_IO functions for reading characters and strings from + Standard_Input, and writing characters, strings and integers to either + Standard_Output or Standard_Error. + +  + File: gnat_rm.info, Node: GNAT.IO_Aux (g-io_aux.ads), Next: GNAT.Lock_Files (g-locfil.ads), Prev: GNAT.IO (g-io.ads), Up: The GNAT Library + + `GNAT.IO_Aux' (`g-io_aux.ads') + ============================== + + Provides some auxiliary functions for use with Text_IO, including a + test for whether a file exists, and functions for reading a line of + text. + +  + File: gnat_rm.info, Node: GNAT.Lock_Files (g-locfil.ads), Next: GNAT.MD5 (g-md5.ads), Prev: GNAT.IO_Aux (g-io_aux.ads), Up: The GNAT Library + + `GNAT.Lock_Files' (`g-locfil.ads') + ================================== + + Provides a general interface for using files as locks. Can be used for + providing program level synchronization. + +  + File: gnat_rm.info, Node: GNAT.MD5 (g-md5.ads), Next: GNAT.Most_Recent_Exception (g-moreex.ads), Prev: GNAT.Lock_Files (g-locfil.ads), Up: The GNAT Library + + `GNAT.MD5' (`g-md5.ads') + ======================== + + Implements the MD5 Message-Digest Algorithm as described in RFC 1321. + +  + File: gnat_rm.info, Node: GNAT.Most_Recent_Exception (g-moreex.ads), Next: GNAT.OS_Lib (g-os_lib.ads), Prev: GNAT.MD5 (g-md5.ads), Up: The GNAT Library + + `GNAT.Most_Recent_Exception' (`g-moreex.ads') + ============================================= + + Provides access to the most recently raised exception. Can be used for + various logging purposes, including duplicating functionality of some + Ada 83 implementation dependent extensions. + +  + File: gnat_rm.info, Node: GNAT.OS_Lib (g-os_lib.ads), Next: GNAT.Regexp (g-regexp.ads), Prev: GNAT.Most_Recent_Exception (g-moreex.ads), Up: The GNAT Library + + `GNAT.OS_Lib' (`g-os_lib.ads') + ============================== + + Provides a range of target independent operating system interface + functions, including time/date management, file operations, subprocess + management, including a portable spawn procedure, and access to + environment variables and error return codes. + +  + File: gnat_rm.info, Node: GNAT.Regexp (g-regexp.ads), Next: GNAT.Registry (g-regist.ads), Prev: GNAT.OS_Lib (g-os_lib.ads), Up: The GNAT Library + + `GNAT.Regexp' (`g-regexp.ads') + ============================== + + A simple implementation of regular expressions, using a subset of + regular expression syntax copied from familiar Unix style utilities. + This is the simples of the three pattern matching packages provided, + and is particularly suitable for "file globbing" applications. + +  + File: gnat_rm.info, Node: GNAT.Registry (g-regist.ads), Next: GNAT.Regpat (g-regpat.ads), Prev: GNAT.Regexp (g-regexp.ads), Up: The GNAT Library + + `GNAT.Registry' (`g-regist.ads') + ================================ + + This is a high level binding to the Windows registry. It is possible to + do simple things like reading a key value, creating a new key. For full + registry API, but at a lower level of abstraction, refer to the + Win32.Winreg package provided with the Win32Ada binding + +  + File: gnat_rm.info, Node: GNAT.Regpat (g-regpat.ads), Next: GNAT.Sockets (g-socket.ads), Prev: GNAT.Registry (g-regist.ads), Up: The GNAT Library + + `GNAT.Regpat' (`g-regpat.ads') + ============================== + + A complete implementation of Unix-style regular expression matching, + copied from the original V7 style regular expression library written in + C by Henry Spencer (and binary compatible with this C library). + +  + File: gnat_rm.info, Node: GNAT.Sockets (g-socket.ads), Next: GNAT.Source_Info (g-souinf.ads), Prev: GNAT.Regpat (g-regpat.ads), Up: The GNAT Library + + `GNAT.Sockets' (`g-socket.ads') + =============================== + + A high level and portable interface to develop sockets based + applications. This package is based on the sockets thin binding found + in GNAT.Sockets.Thin. Currently GNAT.Sockets is implemented on all + native GNAT ports except for OpenVMS. It is not implemented for the + LynxOS cross port. + +  + File: gnat_rm.info, Node: GNAT.Source_Info (g-souinf.ads), Next: GNAT.Spell_Checker (g-speche.ads), Prev: GNAT.Sockets (g-socket.ads), Up: The GNAT Library + + `GNAT.Source_Info' (`g-souinf.ads') + =================================== + + Provides subprograms that give access to source code information known + at compile time, such as the current file name and line number. + +  + File: gnat_rm.info, Node: GNAT.Spell_Checker (g-speche.ads), Next: GNAT.Spitbol.Patterns (g-spipat.ads), Prev: GNAT.Source_Info (g-souinf.ads), Up: The GNAT Library + + `GNAT.Spell_Checker' (`g-speche.ads') + ===================================== + + Provides a function for determining whether one string is a plausible + near misspelling of another string. + +  + File: gnat_rm.info, Node: GNAT.Spitbol.Patterns (g-spipat.ads), Next: GNAT.Spitbol (g-spitbo.ads), Prev: GNAT.Spell_Checker (g-speche.ads), Up: The GNAT Library + + `GNAT.Spitbol.Patterns' (`g-spipat.ads') + ======================================== + + A complete implementation of SNOBOL4 style pattern matching. This is + the most elaborate of the pattern matching packages provided. It fully + duplicates the SNOBOL4 dynamic pattern construction and matching + capabilities, using the efficient algorithm developed by Robert Dewar + for the SPITBOL system. + +  + File: gnat_rm.info, Node: GNAT.Spitbol (g-spitbo.ads), Next: GNAT.Spitbol.Table_Boolean (g-sptabo.ads), Prev: GNAT.Spitbol.Patterns (g-spipat.ads), Up: The GNAT Library + + `GNAT.Spitbol' (`g-spitbo.ads') + =============================== + + The top level package of the collection of SPITBOL-style functionality, + this package provides basic SNOBOL4 string manipulation functions, such + as Pad, Reverse, Trim, Substr capability, as well as a generic table + function useful for constructing arbitrary mappings from strings in the + style of the SNOBOL4 TABLE function. + +  + File: gnat_rm.info, Node: GNAT.Spitbol.Table_Boolean (g-sptabo.ads), Next: GNAT.Spitbol.Table_Integer (g-sptain.ads), Prev: GNAT.Spitbol (g-spitbo.ads), Up: The GNAT Library + + `GNAT.Spitbol.Table_Boolean' (`g-sptabo.ads') + ============================================= + + A library level of instantiation of `GNAT.Spitbol.Patterns.Table' for + type `Standard.Boolean', giving an implementation of sets of string + values. + +  + File: gnat_rm.info, Node: GNAT.Spitbol.Table_Integer (g-sptain.ads), Next: GNAT.Spitbol.Table_VString (g-sptavs.ads), Prev: GNAT.Spitbol.Table_Boolean (g-sptabo.ads), Up: The GNAT Library + + `GNAT.Spitbol.Table_Integer' (`g-sptain.ads') + ============================================= + + A library level of instantiation of `GNAT.Spitbol.Patterns.Table' for + type `Standard.Integer', giving an implementation of maps from string + to integer values. + +  + File: gnat_rm.info, Node: GNAT.Spitbol.Table_VString (g-sptavs.ads), Next: GNAT.Table (g-table.ads), Prev: GNAT.Spitbol.Table_Integer (g-sptain.ads), Up: The GNAT Library + + `GNAT.Spitbol.Table_VString' (`g-sptavs.ads') + ============================================= + + A library level of instantiation of GNAT.Spitbol.Patterns.Table for a + variable length string type, giving an implementation of general maps + from strings to strings. + +  + File: gnat_rm.info, Node: GNAT.Table (g-table.ads), Next: GNAT.Task_Lock (g-tasloc.ads), Prev: GNAT.Spitbol.Table_VString (g-sptavs.ads), Up: The GNAT Library + + `GNAT.Table' (`g-table.ads') + ============================ + + A generic package providing a single dimension array abstraction where + the length of the array can be dynamically modified. + + This package provides a facility similar to that of GNAT.Dynamic_Tables, + except that this package declares a single instance of the table type, + while an instantiation of GNAT.Dynamic_Tables creates a type that can be + used to define dynamic instances of the table. + +  + File: gnat_rm.info, Node: GNAT.Task_Lock (g-tasloc.ads), Next: GNAT.Threads (g-thread.ads), Prev: GNAT.Table (g-table.ads), Up: The GNAT Library + + `GNAT.Task_Lock' (`g-tasloc.ads') + ================================= + + A very simple facility for locking and unlocking sections of code using + a single global task lock. Appropriate for use in situations where + contention between tasks is very rarely expected. + +  + File: gnat_rm.info, Node: GNAT.Threads (g-thread.ads), Next: GNAT.Traceback (g-traceb.ads), Prev: GNAT.Task_Lock (g-tasloc.ads), Up: The GNAT Library + + `GNAT.Threads' (`g-thread.ads') + =============================== + + Provides facilities for creating and destroying threads with explicit + calls. These threads are known to the GNAT run-time system. These + subprograms are exported C-convention procedures intended to be called + from foreign code. By using these primitives rather than directly + calling operating systems routines, compatibility with the Ada tasking + runt-time is provided. + +  + File: gnat_rm.info, Node: GNAT.Traceback (g-traceb.ads), Next: GNAT.Traceback.Symbolic (g-trasym.ads), Prev: GNAT.Threads (g-thread.ads), Up: The GNAT Library + + `GNAT.Traceback' (`g-traceb.ads') + ================================= + + Provides a facility for obtaining non-symbolic traceback information, + useful in various debugging situations. + +  + File: gnat_rm.info, Node: GNAT.Traceback.Symbolic (g-trasym.ads), Next: Interfaces.C.Extensions (i-cexten.ads), Prev: GNAT.Traceback (g-traceb.ads), Up: The GNAT Library + + `GNAT.Traceback.Symbolic' (`g-trasym.ads') + ========================================== + + Provides symbolic traceback information that includes the subprogram + name and line number information. + +  + File: gnat_rm.info, Node: Interfaces.C.Extensions (i-cexten.ads), Next: Interfaces.C.Streams (i-cstrea.ads), Prev: GNAT.Traceback.Symbolic (g-trasym.ads), Up: The GNAT Library + + `Interfaces.C.Extensions' (`i-cexten.ads') + ========================================== + + This package contains additional C-related definitions, intended for + use with either manually or automatically generated bindings to C + libraries. + +  + File: gnat_rm.info, Node: Interfaces.C.Streams (i-cstrea.ads), Next: Interfaces.CPP (i-cpp.ads), Prev: Interfaces.C.Extensions (i-cexten.ads), Up: The GNAT Library + + `Interfaces.C.Streams' (`i-cstrea.ads') + ======================================= + + This package is a binding for the most commonly used operations on C + streams. + +  + File: gnat_rm.info, Node: Interfaces.CPP (i-cpp.ads), Next: Interfaces.Os2lib (i-os2lib.ads), Prev: Interfaces.C.Streams (i-cstrea.ads), Up: The GNAT Library + + `Interfaces.CPP' (`i-cpp.ads') + ============================== + + This package provides facilities for use in interfacing to C++. It is + primarily intended to be used in connection with automated tools for + the generation of C++ interfaces. + +  + File: gnat_rm.info, Node: Interfaces.Os2lib (i-os2lib.ads), Next: Interfaces.Os2lib.Errors (i-os2err.ads), Prev: Interfaces.CPP (i-cpp.ads), Up: The GNAT Library + + `Interfaces.Os2lib' (`i-os2lib.ads') + ==================================== + + This package provides interface definitions to the OS/2 library. It is + a thin binding which is a direct translation of the various `' + files. + +  + File: gnat_rm.info, Node: Interfaces.Os2lib.Errors (i-os2err.ads), Next: Interfaces.Os2lib.Synchronization (i-os2syn.ads), Prev: Interfaces.Os2lib (i-os2lib.ads), Up: The GNAT Library + + `Interfaces.Os2lib.Errors' (`i-os2err.ads') + =========================================== + + This package provides definitions of the OS/2 error codes. + +  + File: gnat_rm.info, Node: Interfaces.Os2lib.Synchronization (i-os2syn.ads), Next: Interfaces.Os2lib.Threads (i-os2thr.ads), Prev: Interfaces.Os2lib.Errors (i-os2err.ads), Up: The GNAT Library + + `Interfaces.Os2lib.Synchronization' (`i-os2syn.ads') + ==================================================== + + This is a child package that provides definitions for interfacing to + the `OS/2' synchronization primitives. + +  + File: gnat_rm.info, Node: Interfaces.Os2lib.Threads (i-os2thr.ads), Next: Interfaces.Packed_Decimal (i-pacdec.ads), Prev: Interfaces.Os2lib.Synchronization (i-os2syn.ads), Up: The GNAT Library + + `Interfaces.Os2lib.Threads' (`i-os2thr.ads') + ============================================ + + This is a child package that provides definitions for interfacing to + the `OS/2' thread primitives. + +  + File: gnat_rm.info, Node: Interfaces.Packed_Decimal (i-pacdec.ads), Next: Interfaces.VxWorks (i-vxwork.ads), Prev: Interfaces.Os2lib.Threads (i-os2thr.ads), Up: The GNAT Library + + `Interfaces.Packed_Decimal' (`i-pacdec.ads') + ============================================ + + This package provides a set of routines for conversions to and from a + packed decimal format compatible with that used on IBM mainframes. + +  + File: gnat_rm.info, Node: Interfaces.VxWorks (i-vxwork.ads), Next: Interfaces.VxWorks.IO (i-vxwoio.ads), Prev: Interfaces.Packed_Decimal (i-pacdec.ads), Up: The GNAT Library + + `Interfaces.VxWorks' (`i-vxwork.ads') + ===================================== + + This package provides a limited binding to the VxWorks API. In + particular, it interfaces with the VxWorks hardware interrupt + facilities. + +  + File: gnat_rm.info, Node: Interfaces.VxWorks.IO (i-vxwoio.ads), Next: System.Address_Image (s-addima.ads), Prev: Interfaces.VxWorks (i-vxwork.ads), Up: The GNAT Library + + `Interfaces.VxWorks.IO' (`i-vxwoio.ads') + ======================================== + + This package provides a limited binding to the VxWorks' I/O API. In + particular, it provides procedures that enable the use of Get_Immediate + under VxWorks. + +  + File: gnat_rm.info, Node: System.Address_Image (s-addima.ads), Next: System.Assertions (s-assert.ads), Prev: Interfaces.VxWorks.IO (i-vxwoio.ads), Up: The GNAT Library + + `System.Address_Image' (`s-addima.ads') + ======================================= + + This function provides a useful debugging function that gives an + (implementation dependent) string which identifies an address. + +  + File: gnat_rm.info, Node: System.Assertions (s-assert.ads), Next: System.Partition_Interface (s-parint.ads), Prev: System.Address_Image (s-addima.ads), Up: The GNAT Library + + `System.Assertions' (`s-assert.ads') + ==================================== + + This package provides the declaration of the exception raised by an + run-time assertion failure, as well as the routine that is used + internally to raise this assertion. + +  + File: gnat_rm.info, Node: System.Partition_Interface (s-parint.ads), Next: System.Task_Info (s-tasinf.ads), Prev: System.Assertions (s-assert.ads), Up: The GNAT Library + + `System.Partition_Interface' (`s-parint.ads') + ============================================= + + This package provides facilities for partition interfacing. It is used + primarily in a distribution context when using Annex E with `GLADE'. + +  + File: gnat_rm.info, Node: System.Task_Info (s-tasinf.ads), Next: System.Wch_Cnv (s-wchcnv.ads), Prev: System.Partition_Interface (s-parint.ads), Up: The GNAT Library + + `System.Task_Info' (`s-tasinf.ads') + =================================== + + This package provides target dependent functionality that is used to + support the `Task_Info' pragma + +  + File: gnat_rm.info, Node: System.Wch_Cnv (s-wchcnv.ads), Next: System.Wch_Con (s-wchcon.ads), Prev: System.Task_Info (s-tasinf.ads), Up: The GNAT Library + + `System.Wch_Cnv' (`s-wchcnv.ads') + ================================= + + This package provides routines for converting between wide characters + and a representation as a value of type `Standard.String', using a + specified wide character encoding method. It uses definitions in + package `System.Wch_Con'. + +  + File: gnat_rm.info, Node: System.Wch_Con (s-wchcon.ads), Prev: System.Wch_Cnv (s-wchcnv.ads), Up: The GNAT Library + + `System.Wch_Con' (`s-wchcon.ads') + ================================= + + This package provides definitions and descriptions of the various + methods used for encoding wide characters in ordinary strings. These + definitions are used by the package `System.Wch_Cnv'. + +  + File: gnat_rm.info, Node: Interfacing to Other Languages, Next: Machine Code Insertions, Prev: The GNAT Library, Up: Top + + Interfacing to Other Languages + ****************************** + + The facilities in annex B of the Ada 95 Reference Manual are fully + implemented in GNAT, and in addition, a full interface to C++ is + provided. + + * Menu: + + * Interfacing to C:: + * Interfacing to C++:: + * Interfacing to COBOL:: + * Interfacing to Fortran:: + * Interfacing to non-GNAT Ada code:: + +  + File: gnat_rm.info, Node: Interfacing to C, Next: Interfacing to C++, Up: Interfacing to Other Languages + + Interfacing to C + ================ + + Interfacing to C with GNAT can use one of two approaches: + + 1. The types in the package `Interfaces.C' may be used. + + 2. Standard Ada types may be used directly. This may be less + portable to other compilers, but will work on all GNAT compilers, + which guarantee correspondence between the C and Ada types. + + Pragma `Convention C' maybe applied to Ada types, but mostly has no + effect, since this is the default. The following table shows the + correspondence between Ada scalar types and the corresponding C types. + + `Integer' + `int' + + `Short_Integer' + `short' + + `Short_Short_Integer' + `signed char' + + `Long_Integer' + `long' + + `Long_Long_Integer' + `long long' + + `Short_Float' + `float' + + `Float' + `float' + + `Long_Float' + `double' + + `Long_Long_Float' + This is the longest floating-point type supported by the hardware. + + * Ada enumeration types map to C enumeration types directly if pragma + `Convention C' is specified, which causes them to have int length. + Without pragma `Convention C', Ada enumeration types map to 8, + 16, or 32 bits (i.e. C types `signed char', `short', `int', + respectively) depending on the number of values passed. This is + the only case in which pragma `Convention C' affects the + representation of an Ada type. + + * Ada access types map to C pointers, except for the case of + pointers to unconstrained types in Ada, which have no direct C + equivalent. + + * Ada arrays map directly to C arrays. + + * Ada records map directly to C structures. + + * Packed Ada records map to C structures where all members are bit + fields of the length corresponding to the `TYPE'Size' value in Ada. + +  + File: gnat_rm.info, Node: Interfacing to C++, Next: Interfacing to COBOL, Prev: Interfacing to C, Up: Interfacing to Other Languages + + Interfacing to C++ + ================== + + The interface to C++ makes use of the following pragmas, which are + primarily intended to be constructed automatically using a binding + generator tool, although it is possible to construct them by hand. Ada + Core Technologies does not currently supply a suitable binding + generator tool. + + Using these pragmas it is possible to achieve complete + inter-operability between Ada tagged types and C class definitions. + See *Note Implementation Defined Pragmas:: for more details. + + `pragma CPP_Class ([Entity =>] LOCAL_NAME)' + The argument denotes an entity in the current declarative region + that is declared as a tagged or untagged record type. It + indicates that the type corresponds to an externally declared C++ + class type, and is to be laid out the same way that C++ would lay + out the type. + + `pragma CPP_Constructor ([Entity =>] LOCAL_NAME)' + This pragma identifies an imported function (imported in the usual + way with pragma `Import') as corresponding to a C++ constructor. + + `pragma CPP_Vtable ...' + One `CPP_Vtable' pragma can be present for each component of type + `CPP.Interfaces.Vtable_Ptr' in a record to which pragma `CPP_Class' + applies. + +  + File: gnat_rm.info, Node: Interfacing to COBOL, Next: Interfacing to Fortran, Prev: Interfacing to C++, Up: Interfacing to Other Languages + + Interfacing to COBOL + ==================== + + Interfacing to COBOL is achieved as described in section B.4 of the Ada + 95 reference manual. + +  + File: gnat_rm.info, Node: Interfacing to Fortran, Next: Interfacing to non-GNAT Ada code, Prev: Interfacing to COBOL, Up: Interfacing to Other Languages + + Interfacing to Fortran + ====================== + + Interfacing to Fortran is achieved as described in section B.5 of the + reference manual. The pragma `Convention Fortran', applied to a + multi-dimensional array causes the array to be stored in column-major + order as required for convenient interface to Fortran. + +  + File: gnat_rm.info, Node: Interfacing to non-GNAT Ada code, Prev: Interfacing to Fortran, Up: Interfacing to Other Languages + + Interfacing to non-GNAT Ada code + ================================ + + It is possible to specify the convention `Ada' in a pragma `Import' + or pragma `Export'. However this refers to the calling conventions used + by GNAT, which may or may not be similar enough to those used by some + other Ada 83 or Ada 95 compiler to allow interoperation. + + If arguments types are kept simple, and if the foreign compiler + generally follows system calling conventions, then it may be possible + to integrate files compiled by other Ada compilers, provided that the + elaboration issues are adequately addressed (for example by eliminating + the need for any load time elaboration). + + In particular, GNAT running on VMS is designed to be highly + compatible with the DEC Ada 83 compiler, so this is one case in which + it is possible to import foreign units of this type, provided that the + data items passed are restricted to simple scalar values or simple + record types without variants, or simple array types with fixed bounds. + +  + File: gnat_rm.info, Node: Machine Code Insertions, Next: GNAT Implementation of Tasking, Prev: Interfacing to Other Languages, Up: Top + + Machine Code Insertions + *********************** + + Package `Machine_Code' provides machine code support as described in + the Ada 95 Reference Manual in two separate forms: + * Machine code statements, consisting of qualified expressions that + fit the requirements of RM section 13.8. + + * An intrinsic callable procedure, providing an alternative + mechanism of including machine instructions in a subprogram. + + The two features are similar, and both closely related to the + mechanism provided by the asm instruction in the GNU C compiler. Full + understanding and use of the facilities in this package requires + understanding the asm instruction as described in `Using and Porting + the GNU Compiler Collection (GCC)' by Richard Stallman. Calls to the + function `Asm' and the procedure `Asm' have identical semantic + restrictions and effects as described below. Both are provided so that + the procedure call can be used as a statement, and the function call + can be used to form a code_statement. + + The first example given in the GCC documentation is the C `asm' + instruction: + asm ("fsinx %1 %0" : "=f" (result) : "f" (angle)); + + The equivalent can be written for GNAT as: + + Asm ("fsinx %1 %0", + My_Float'Asm_Output ("=f", result), + My_Float'Asm_Input ("f", angle)); + + The first argument to `Asm' is the assembler template, and is + identical to what is used in GNU C. This string must be a static + expression. The second argument is the output operand list. It is + either a single `Asm_Output' attribute reference, or a list of such + references enclosed in parentheses (technically an array aggregate of + such references). + + The `Asm_Output' attribute denotes a function that takes two + parameters. The first is a string, the second is the name of a variable + of the type designated by the attribute prefix. The first (string) + argument is required to be a static expression and designates the + constraint for the parameter (e.g. what kind of register is required). + The second argument is the variable to be updated with the result. The + possible values for constraint are the same as those used in the RTL, + and are dependent on the configuration file used to build the GCC back + end. If there are no output operands, then this argument may either be + omitted, or explicitly given as `No_Output_Operands'. + + The second argument of `MY_FLOAT'Asm_Output' functions as though it + were an `out' parameter, which is a little curious, but all names have + the form of expressions, so there is no syntactic irregularity, even + though normally functions would not be permitted `out' parameters. The + third argument is the list of input operands. It is either a single + `Asm_Input' attribute reference, or a list of such references enclosed + in parentheses (technically an array aggregate of such references). + + The `Asm_Input' attribute denotes a function that takes two + parameters. The first is a string, the second is an expression of the + type designated by the prefix. The first (string) argument is required + to be a static expression, and is the constraint for the parameter, + (e.g. what kind of register is required). The second argument is the + value to be used as the input argument. The possible values for the + constant are the same as those used in the RTL, and are dependent on + the configuration file used to built the GCC back end. + + If there are no input operands, this argument may either be omitted, + or explicitly given as `No_Input_Operands'. The fourth argument, not + present in the above example, is a list of register names, called the + "clobber" argument. This argument, if given, must be a static string + expression, and is a space or comma separated list of names of registers + that must be considered destroyed as a result of the `Asm' call. If + this argument is the null string (the default value), then the code + generator assumes that no additional registers are destroyed. + + The fifth argument, not present in the above example, called the + "volatile" argument, is by default `False'. It can be set to the + literal value `True' to indicate to the code generator that all + optimizations with respect to the instruction specified should be + suppressed, and that in particular, for an instruction that has outputs, + the instruction will still be generated, even if none of the outputs are + used. See the full description in the GCC manual for further details. + + The `Asm' subprograms may be used in two ways. First the procedure + forms can be used anywhere a procedure call would be valid, and + correspond to what the RM calls "intrinsic" routines. Such calls can + be used to intersperse machine instructions with other Ada statements. + Second, the function forms, which return a dummy value of the limited + private type `Asm_Insn', can be used in code statements, and indeed + this is the only context where such calls are allowed. Code statements + appear as aggregates of the form: + + Asm_Insn'(Asm (...)); + Asm_Insn'(Asm_Volatile (...)); + + In accordance with RM rules, such code statements are allowed only + within subprograms whose entire body consists of such statements. It is + not permissible to intermix such statements with other Ada statements. + + Typically the form using intrinsic procedure calls is more convenient + and more flexible. The code statement form is provided to meet the RM + suggestion that such a facility should be made available. The following + is the exact syntax of the call to `Asm' (of course if named notation is + used, the arguments may be given in arbitrary order, following the + normal rules for use of positional and named arguments) + + ASM_CALL ::= Asm ( + [Template =>] static_string_EXPRESSION + [,[Outputs =>] OUTPUT_OPERAND_LIST ] + [,[Inputs =>] INPUT_OPERAND_LIST ] + [,[Clobber =>] static_string_EXPRESSION ] + [,[Volatile =>] static_boolean_EXPRESSION] ) + OUTPUT_OPERAND_LIST ::= + No_Output_Operands + | OUTPUT_OPERAND_ATTRIBUTE + | (OUTPUT_OPERAND_ATTRIBUTE {,OUTPUT_OPERAND_ATTRIBUTE}) + OUTPUT_OPERAND_ATTRIBUTE ::= + SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME) + INPUT_OPERAND_LIST ::= + No_Input_Operands + | INPUT_OPERAND_ATTRIBUTE + | (INPUT_OPERAND_ATTRIBUTE {,INPUT_OPERAND_ATTRIBUTE}) + INPUT_OPERAND_ATTRIBUTE ::= + SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION) + +  + File: gnat_rm.info, Node: GNAT Implementation of Tasking, Next: Code generation for array aggregates, Prev: Machine Code Insertions, Up: Top + + GNAT Implementation of Tasking + ****************************** + + * Menu: + + * Mapping Ada Tasks onto the Underlying Kernel Threads:: + * Ensuring Compliance with the Real-Time Annex:: + +  + File: gnat_rm.info, Node: Mapping Ada Tasks onto the Underlying Kernel Threads, Next: Ensuring Compliance with the Real-Time Annex, Up: GNAT Implementation of Tasking + + Mapping Ada Tasks onto the Underlying Kernel Threads + ==================================================== + + GNAT run-time system comprises two layers: + + * GNARL (GNAT Run-time Layer) + + * GNULL (GNAT Low-level Library) + + In GNAT, Ada's tasking services rely on a platform and OS independent + layer known as GNARL. This code is responsible for implementing the + correct semantics of Ada's task creation, rendezvous, protected + operations etc. + + GNARL decomposes Ada's tasking semantics into simpler lower level + operations such as create a thread, set the priority of a thread, + yield, create a lock, lock/unlock, etc. The spec for these low-level + operations constitutes GNULLI, the GNULL Interface. This interface is + directly inspired from the POSIX real-time API. + + If the underlying executive or OS implements the POSIX standard + faithfully, the GNULL Interface maps as is to the services offered by + the underlying kernel. Otherwise, some target dependent glue code maps + the services offered by the underlying kernel to the semantics expected + by GNARL. + + Whatever the underlying OS (VxWorks, UNIX, OS/2, Windows NT, etc.) + the key point is that each Ada task is mapped on a thread in the + underlying kernel. For example, in the case of VxWorks, one Ada task = + one VxWorks task. + + In addition Ada task priorities map onto the underlying thread + priorities. Mapping Ada tasks onto the underlying kernel threads has + several advantages: + + 1. The underlying scheduler is used to schedule the Ada tasks. This + makes Ada tasks as efficient as kernel threads from a scheduling + standpoint. + + 2. Interaction with code written in C containing threads is eased + since at the lowest level Ada tasks and C threads map onto the same + underlying kernel concept. + + 3. When an Ada task is blocked during I/O the remaining Ada tasks are + able to proceed. + + 4. On multi-processor systems Ada Tasks can execute in parallel. + +  + File: gnat_rm.info, Node: Ensuring Compliance with the Real-Time Annex, Prev: Mapping Ada Tasks onto the Underlying Kernel Threads, Up: GNAT Implementation of Tasking + + Ensuring Compliance with the Real-Time Annex + ============================================ + + The reader will be quick to notice that while mapping Ada tasks onto + the underlying threads has significant advantages, it does create some + complications when it comes to respecting the scheduling semantics + specified in the real-time annex (Annex D). + + For instance Annex D requires that for the FIFO_Within_Priorities + scheduling policy we have: + + When the active priority of a ready task that is not running + changes, or the setting of its base priority takes effect, the + task is removed from the ready queue for its old active priority + and is added at the tail of the ready queue for its new active + priority, except in the case where the active priority is lowered + due to the loss of inherited priority, in which case the task is + added at the head of the ready queue for its new active priority. + + While most kernels do put tasks at the end of the priority queue when + a task changes its priority, (which respects the main + FIFO_Within_Priorities requirement), almost none keep a thread at the + beginning of its priority queue when its priority drops from the loss + of inherited priority. + + As a result most vendors have provided incomplete Annex D + implementations. + + The GNAT run-time, has a nice cooperative solution to this problem + which ensures that accurate FIFO_Within_Priorities semantics are + respected. + + The principle is as follows. When an Ada task T is about to start + running, it checks whether some other Ada task R with the same priority + as T has been suspended due to the loss of priority inheritance. If + this is the case, T yields and is placed at the end of its priority + queue. When R arrives at the front of the queue it executes. + + Note that this simple scheme preserves the relative order of the + tasks that were ready to execute in the priority queue where R has been + placed at the end. + +  + File: gnat_rm.info, Node: Code generation for array aggregates, Next: Specialized Needs Annexes, Prev: GNAT Implementation of Tasking, Up: Top + + Code generation for array aggregates + ************************************ + + * Menu: + + * Static constant aggregates with static bounds:: + * Constant aggregates with an unconstrained nominal types:: + * Aggregates with static bounds:: + * Aggregates with non-static bounds:: + * Aggregates in assignments statements:: + + Aggregate have a rich syntax and allow the user to specify the + values of complex data structures by means of a single construct. As a + result, the code generated for aggregates can be quite complex and + involve loops, case statements and multiple assignments. In the + simplest cases, however, the compiler will recognize aggregates whose + components and constraints are fully static, and in those cases the + compiler will generate little or no executable code. The following is + an outline of the code that GNAT generates for various aggregate + constructs. For further details, the user will find it useful to + examine the output produced by the -gnatG flag to see the expanded + source that is input to the code generator. The user will also want to + examine the assembly code generated at various levels of optimization. + + The code generated for aggregates depends on the context, the + component values, and the type. In the context of an object + declaration the code generated is generally simpler than in the case of + an assignment. As a general rule, static component values and static + subtypes also lead to simpler code. + +  + File: gnat_rm.info, Node: Static constant aggregates with static bounds, Next: Constant aggregates with an unconstrained nominal types, Up: Code generation for array aggregates + + Static constant aggregates with static bounds + ============================================= + + For the declarations: + type One_Dim is array (1..10) of integer; + ar0 : constant One_Dim := ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 0); + + GNAT generates no executable code: the constant ar0 is placed in + static memory. The same is true for constant aggregates with named + associations: + + Cr1 : constant One_Dim := (4 => 16, 2 => 4, 3 => 9, 1=> 1); + Cr3 : constant One_Dim := (others => 7777); + + The same is true for multidimensional constant arrays such as: + + type two_dim is array (1..3, 1..3) of integer; + Unit : constant two_dim := ( (1,0,0), (0,1,0), (0,0,1)); + + The same is true for arrays of one-dimensional arrays: the following + are static: + + type ar1b is array (1..3) of boolean; + type ar_ar is array (1..3) of ar1b; + None : constant ar1b := (others => false); -- fully static + None2 : constant ar_ar := (1..3 => None); -- fully static + + However, for multidimensional aggregates with named associations, + GNAT will generate assignments and loops, even if all associations are + static. The following two declarations generate a loop for the first + dimension, and individual component assignments for the second + dimension: + + Zero1: constant two_dim := (1..3 => (1..3 => 0)); + Zero2: constant two_dim := (others => (others => 0)); + +  + File: gnat_rm.info, Node: Constant aggregates with an unconstrained nominal types, Next: Aggregates with static bounds, Prev: Static constant aggregates with static bounds, Up: Code generation for array aggregates + + Constant aggregates with an unconstrained nominal types + ======================================================= + + In such cases the aggregate itself establishes the subtype, so that + associations with `others' cannot be used. GNAT determines the bounds + for the actual subtype of the aggregate, and allocates the aggregate + statically as well. No code is generated for the following: + + type One_Unc is array (natural range <>) of integer; + Cr_Unc : constant One_Unc := (12,24,36); + +  + File: gnat_rm.info, Node: Aggregates with static bounds, Next: Aggregates with non-static bounds, Prev: Constant aggregates with an unconstrained nominal types, Up: Code generation for array aggregates + + Aggregates with static bounds + ============================= + + In all previous examples the aggregate was the initial (and + immutable) value of a constant. If the aggregate initializes a + variable, then code is generated for it as a combination of individual + assignments and loops over the target object. The declarations + + Cr_Var1 : One_Dim := (2, 5, 7, 11); + Cr_Var2 : One_Dim := (others > -1); + + generate the equivalent of + + Cr_Var1 (1) := 2; + Cr_Var1 (2) := 3; + Cr_Var1 (3) := 5; + Cr_Var1 (4) := 11; + + for I in Cr_Var2'range loop + Cr_Var2 (I) := =-1; + end loop; + +  + File: gnat_rm.info, Node: Aggregates with non-static bounds, Next: Aggregates in assignments statements, Prev: Aggregates with static bounds, Up: Code generation for array aggregates + + Aggregates with non-static bounds + ================================= + + If the bounds of the aggregate are not statically compatible with + the bounds of the nominal subtype of the target, then constraint + checks have to be generated on the bounds. For a multidimensional + array, constraint checks may have to be applied to sub-arrays + individually, if they do not have statically compatible subtypes. + +  + File: gnat_rm.info, Node: Aggregates in assignments statements, Prev: Aggregates with non-static bounds, Up: Code generation for array aggregates + + Aggregates in assignments statements + ==================================== + + In general, aggregate assignment requires the construction of a + temporary, and a copy from the temporary to the target of the + assignment. This is because it is not always possible to convert the + assignment into a series of individual component assignments. For + example, consider the simple case: + + A := (A(2), A(1)); + + This cannot be converted into: + + A(1) := A(2); + A(2) := A(1); + + So the aggregate has to be built first in a separate location, and + then copied into the target. GNAT recognizes simple cases where this + intermediate step is not required, and the assignments can be performed + in place, directly into the target. The following sufficient criteria + are applied: + + 1. The bounds of the aggregate are static, and the associations are + static. + + 2. The components of the aggregate are static constants, names of + simple variables that are not renamings, or expressions not + involving indexed components whose operands obey these rules. + + If any of these conditions are violated, the aggregate will be built + in a temporary (created either by the front-end or the code generator) + and then that temporary will be copied onto the target. + +  + File: gnat_rm.info, Node: Specialized Needs Annexes, Next: Compatibility Guide, Prev: Code generation for array aggregates, Up: Top + + Specialized Needs Annexes + ************************* + + Ada 95 defines a number of specialized needs annexes, which are not + required in all implementations. However, as described in this chapter, + GNAT implements all of these special needs annexes: + + Systems Programming (Annex C) + The Systems Programming Annex is fully implemented. + + Real-Time Systems (Annex D) + The Real-Time Systems Annex is fully implemented. + + Distributed Systems (Annex E) + Stub generation is fully implemented in the GNAT compiler. In + addition, a complete compatible PCS is available as part of the + GLADE system, a separate product. When the two products are used + in conjunction, this annex is fully implemented. + + Information Systems (Annex F) + The Information Systems annex is fully implemented. + + Numerics (Annex G) + The Numerics Annex is fully implemented. + + Safety and Security (Annex H) + The Safety and Security annex is fully implemented. + +  + File: gnat_rm.info, Node: Compatibility Guide, Next: GNU Free Documentation License, Prev: Specialized Needs Annexes, Up: Top + + Compatibility Guide + ******************* + + This chapter contains sections that describe compatibility issues + between GNAT and other Ada 83 and Ada 95 compilation systems, to aid in + porting applications developed in other Ada environments. + + * Menu: + + * Compatibility with Ada 83:: + * Compatibility with DEC Ada 83:: + * Compatibility with Other Ada 95 Systems:: + * Representation Clauses:: + +  + File: gnat_rm.info, Node: Compatibility with Ada 83, Next: Compatibility with DEC Ada 83, Up: Compatibility Guide + + Compatibility with Ada 83 + ========================= + + Ada 95 is designed to be highly upwards compatible with Ada 83. In + particular, the design intention is that the difficulties associated + with moving from Ada 83 to Ada 95 should be no greater than those that + occur when moving from one Ada 83 system to another. + + However, there are a number of points at which there are minor + incompatibilities. The Ada 95 Annotated Reference Manual contains full + details of these issues, and should be consulted for a complete + treatment. In practice the following are the most likely issues to be + encountered. + + Character range + The range of `Standard.Character' is now the full 256 characters + of Latin-1, whereas in most Ada 83 implementations it was + restricted to 128 characters. This may show up as compile time or + runtime errors. The desirable fix is to adapt the program to + accommodate the full character set, but in some cases it may be + convenient to define a subtype or derived type of Character that + covers only the restricted range. + + New reserved words + The identifiers `abstract', `aliased', `protected', `requeue', + `tagged', and `until' are reserved in Ada 95. Existing Ada 83 + code using any of these identifiers must be edited to use some + alternative name. + + Freezing rules + The rules in Ada 95 are slightly different with regard to the + point at which entities are frozen, and representation pragmas and + clauses are not permitted past the freeze point. This shows up + most typically in the form of an error message complaining that a + representation item appears too late, and the appropriate + corrective action is to move the item nearer to the declaration of + the entity to which it refers. + + A particular case is that representation pragmas (including the + extended DEC Ada 83 compatibility pragmas such as + `Export_Procedure'), cannot be applied to a subprogram body. If + necessary, a separate subprogram declaration must be introduced to + which the pragma can be applied. + + Optional bodies for library packages + In Ada 83, a package that did not require a package body was + nevertheless allowed to have one. This lead to certain surprises + in compiling large systems (situations in which the body could be + unexpectedly ignored). In Ada 95, if a package does not require a + body then it is not permitted to have a body. To fix this + problem, simply remove a redundant body if it is empty, or, if it + is non-empty, introduce a dummy declaration into the spec that + makes the body required. One approach is to add a private part to + the package declaration (if necessary), and define a parameterless + procedure called Requires_Body, which must then be given a dummy + procedure body in the package body, which then becomes required. + + `Numeric_Error' is now the same as `Constraint_Error' + In Ada 95, the exception `Numeric_Error' is a renaming of + `Constraint_Error'. This means that it is illegal to have + separate exception handlers for the two exceptions. The fix is + simply to remove the handler for the `Numeric_Error' case (since + even in Ada 83, a compiler was free to raise `Constraint_Error' in + place of `Numeric_Error' in all cases). + + Indefinite subtypes in generics + In Ada 83, it was permissible to pass an indefinite type (e.g. + `String') as the actual for a generic formal private type, but + then the instantiation would be illegal if there were any + instances of declarations of variables of this type in the generic + body. In Ada 95, to avoid this clear violation of the contract + model, the generic declaration clearly indicates whether or not + such instantiations are permitted. If a generic formal parameter + has explicit unknown discriminants, indicated by using `(<>)' + after the type name, then it can be instantiated with indefinite + types, but no variables can be declared of this type. Any attempt + to declare a variable will result in an illegality at the time the + generic is declared. If the `(<>)' notation is not used, then it + is illegal to instantiate the generic with an indefinite type. + This will show up as a compile time error, and the fix is usually + simply to add the `(<>)' to the generic declaration. + + All implementations of GNAT provide a switch that causes GNAT to + operate in Ada 83 mode. In this mode, some but not all compatibility + problems of the type described above are handled automatically. For + example, the new Ada 95 protected keywords are not recognized in this + mode. However, in practice, it is usually advisable to make the + necessary modifications to the program to remove the need for using + this switch. + +  + File: gnat_rm.info, Node: Compatibility with Other Ada 95 Systems, Next: Representation Clauses, Prev: Compatibility with DEC Ada 83, Up: Compatibility Guide + + Compatibility with Other Ada 95 Systems + ======================================= + + Providing that programs avoid the use of implementation dependent and + implementation defined features of Ada 95, as documented in the Ada 95 + reference manual, there should be a high degree of portability between + GNAT and other Ada 95 systems. The following are specific items which + have proved troublesome in moving GNAT programs to other Ada 95 + compilers, but do not affect porting code to GNAT. + + Ada 83 Pragmas and Attributes + Ada 95 compilers are allowed, but not required, to implement the + missing Ada 83 pragmas and attributes that are no longer defined + in Ada 95. GNAT implements all such pragmas and attributes, + eliminating this as a compatibility concern, but some other Ada 95 + compilers reject these pragmas and attributes. + + Special-needs Annexes + GNAT implements the full set of special needs annexes. At the + current time, it is the only Ada 95 compiler to do so. This means + that programs making use of these features may not be portable to + other Ada 95 compilation systems. + + Representation Clauses + Some other Ada 95 compilers implement only the minimal set of + representation clauses required by the Ada 95 reference manual. + GNAT goes far beyond this minimal set, as described in the next + section. + +  + File: gnat_rm.info, Node: Representation Clauses, Prev: Compatibility with Other Ada 95 Systems, Up: Compatibility Guide + + Representation Clauses + ====================== + + The Ada 83 reference manual was quite vague in describing both the + minimal required implementation of representation clauses, and also + their precise effects. The Ada 95 reference manual is much more + explicit, but the minimal set of capabilities required in Ada 95 is + quite limited. + + GNAT implements the full required set of capabilities described in + the Ada 95 reference manual, but also goes much beyond this, and in + particular an effort has been made to be compatible with existing Ada + 83 usage to the greatest extent possible. + + A few cases exist in which Ada 83 compiler behavior is incompatible + with requirements in the Ada 95 reference manual. These are instances + of intentional or accidental dependence on specific implementation + dependent characteristics of these Ada 83 compilers. The following is + a list of the cases most likely to arise in existing legacy Ada 83 code. + + Implicit Packing + Some Ada 83 compilers allowed a Size specification to cause + implicit packing of an array or record. This could cause + expensive implicit conversions for change of representation in the + presence of derived types, and the Ada design intends to avoid + this possibility. Subsequent AI's were issued to make it clear + that such implicit change of representation in response to a Size + clause is inadvisable, and this recommendation is represented + explicitly in the Ada 95 RM as implementation advice that is + followed by GNAT. The problem will show up as an error message + rejecting the size clause. The fix is simply to provide the + explicit pragma `Pack', or for more fine tuned control, provide a + Component_Size clause. + + Meaning of Size Attribute + The Size attribute in Ada 95 for discrete types is defined as + being the minimal number of bits required to hold values of the + type. For example, on a 32-bit machine, the size of Natural will + typically be 31 and not 32 (since no sign bit is required). Some + Ada 83 compilers gave 31, and some 32 in this situation. This + problem will usually show up as a compile time error, but not + always. It is a good idea to check all uses of the 'Size + attribute when porting Ada 83 code. The GNAT specific attribute + Object_Size can provide a useful way of duplicating the behavior of + some Ada 83 compiler systems. + + Size of Access Types + A common assumption in Ada 83 code is that an access type is in + fact a pointer, and that therefore it will be the same size as a + System.Address value. This assumption is true for GNAT in most + cases with one exception. For the case of a pointer to an + unconstrained array type (where the bounds may vary from one value + of the access type to another), the default is to use a "fat + pointer", which is represented as two separate pointers, one to + the bounds, and one to the array. This representation has a + number of advantages, including improved efficiency. However, it + may cause some difficulties in porting existing Ada 83 code which + makes the assumption that, for example, pointers fit in 32 bits on + a machine with 32-bit addressing. + + To get around this problem, GNAT also permits the use of "thin + pointers" for access types in this case (where the designated type + is an unconstrained array type). These thin pointers are indeed + the same size as a System.Address value. To specify a thin + pointer, use a size clause for the type, for example: + + type X is access all String; + for X'Size use Standard'Address_Size; + + which will cause the type X to be represented using a single + pointer. When using this representation, the bounds are right + behind the array. This representation is slightly less efficient, + and does not allow quite such flexibility in the use of foreign + pointers or in using the Unrestricted_Access attribute to create + pointers to non-aliased objects. But for any standard portable + use of the access type it will work in a functionally correct + manner and allow porting of existing code. Note that another way + of forcing a thin pointer representation is to use a component + size clause for the element size in an array, or a record + representation clause for an access field in a record. + +  + File: gnat_rm.info, Node: Compatibility with DEC Ada 83, Next: Compatibility with Other Ada 95 Systems, Prev: Compatibility with Ada 83, Up: Compatibility Guide + + Compatibility with DEC Ada 83 + ============================= + + The VMS version of GNAT fully implements all the pragmas and attributes + provided by DEC Ada 83, as well as providing the standard DEC Ada 83 + libraries, including Starlet. In addition, data layouts and parameter + passing conventions are highly compatible. This means that porting + existing DEC Ada 83 code to GNAT in VMS systems should be easier than + most other porting efforts. The following are some of the most + significant differences between GNAT and DEC Ada 83. + + Default floating-point representation + In GNAT, the default floating-point format is IEEE, whereas in DEC + Ada 83, it is VMS format. GNAT does implement the necessary + pragmas (Long_Float, Float_Representation) for changing this + default. + + System + The package System in GNAT exactly corresponds to the definition + in the Ada 95 reference manual, which means that it excludes many + of the DEC Ada 83 extensions. However, a separate package Aux_DEC + is provided that contains the additional definitions, and a + special pragma, Extend_System allows this package to be treated + transparently as an extension of package System. + + To_Address + The definitions provided by Aux_DEC are exactly compatible with + those in the DEC Ada 83 version of System, with one exception. + DEC Ada provides the following declarations: + + TO_ADDRESS(INTEGER) + TO_ADDRESS(UNSIGNED_LONGWORD) + TO_ADDRESS(universal_integer) + + The version of TO_ADDRESS taking a universal integer argument is + in fact an extension to Ada 83 not strictly compatible with the + reference manual. In GNAT, we are constrained to be exactly + compatible with the standard, and this means we cannot provide + this capability. In DEC Ada 83, the point of this definition is + to deal with a call like: + + TO_ADDRESS (16#12777#); + + Normally, according to the Ada 83 standard, one would expect this + to be ambiguous, since it matches both the INTEGER and + UNSIGNED_LONGWORD forms of TO_ADDRESS. However, in DEC Ada 83, + there is no ambiguity, since the definition using + universal_integer takes precedence. + + In GNAT, since the version with universal_integer cannot be + supplied, it is not possible to be 100% compatible. Since there + are many programs using numeric constants for the argument to + TO_ADDRESS, the decision in GNAT was to change the name of the + function in the UNSIGNED_LONGWORD case, so the declarations + provided in the GNAT version of AUX_Dec are: + + function To_Address (X : Integer) return Address; + pragma Pure_Function (To_Address); + + function To_Address_Long (X : Unsigned_Longword) + return Address; + pragma Pure_Function (To_Address_Long); + + This means that programs using TO_ADDRESS for UNSIGNED_LONGWORD + must change the name to TO_ADDRESS_LONG. + + Task_Id values + The Task_Id values assigned will be different in the two systems, + and GNAT does not provide a specified value for the Task_Id of the + environment task, which in GNAT is treated like any other declared + task. + + For full details on these and other less significant compatibility + issues, see appendix E of the Digital publication entitled `DEC Ada, + Technical Overview and Comparison on DIGITAL Platforms'. + + For GNAT running on other than VMS systems, all the DEC Ada 83 + pragmas and attributes are recognized, although only a subset of them + can sensibly be implemented. The description of pragmas in this + reference manual indicates whether or not they are applicable to + non-VMS systems. + +  + File: gnat_rm.info, Node: GNU Free Documentation License, Next: Index, Prev: Compatibility Guide, Up: Top + + GNU Free Documentation License + ****************************** + + Version 1.2, November 2002 + Copyright (C) 2000,2001,2002 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + 0. PREAMBLE + + The purpose of this License is to make a manual, textbook, or other + functional and useful document "free" in the sense of freedom: to + assure everyone the effective freedom to copy and redistribute it, + with or without modifying it, either commercially or + noncommercially. Secondarily, this License preserves for the + author and publisher a way to get credit for their work, while not + being considered responsible for modifications made by others. + + This License is a kind of "copyleft", which means that derivative + works of the document must themselves be free in the same sense. + It complements the GNU General Public License, which is a copyleft + license designed for free software. + + We have designed this License in order to use it for manuals for + free software, because free software needs free documentation: a + free program should come with manuals providing the same freedoms + that the software does. But this License is not limited to + software manuals; it can be used for any textual work, regardless + of subject matter or whether it is published as a printed book. + We recommend this License principally for works whose purpose is + instruction or reference. + + 1. APPLICABILITY AND DEFINITIONS + + This License applies to any manual or other work, in any medium, + that contains a notice placed by the copyright holder saying it + can be distributed under the terms of this License. Such a notice + grants a world-wide, royalty-free license, unlimited in duration, + to use that work under the conditions stated herein. The + "Document", below, refers to any such manual or work. Any member + of the public is a licensee, and is addressed as "you". You + accept the license if you copy, modify or distribute the work in a + way requiring permission under copyright law. + + A "Modified Version" of the Document means any work containing the + Document or a portion of it, either copied verbatim, or with + modifications and/or translated into another language. + + A "Secondary Section" is a named appendix or a front-matter section + of the Document that deals exclusively with the relationship of the + publishers or authors of the Document to the Document's overall + subject (or to related matters) and contains nothing that could + fall directly within that overall subject. (Thus, if the Document + is in part a textbook of mathematics, a Secondary Section may not + explain any mathematics.) The relationship could be a matter of + historical connection with the subject or with related matters, or + of legal, commercial, philosophical, ethical or political position + regarding them. + + The "Invariant Sections" are certain Secondary Sections whose + titles are designated, as being those of Invariant Sections, in + the notice that says that the Document is released under this + License. If a section does not fit the above definition of + Secondary then it is not allowed to be designated as Invariant. + The Document may contain zero Invariant Sections. If the Document + does not identify any Invariant Sections then there are none. + + The "Cover Texts" are certain short passages of text that are + listed, as Front-Cover Texts or Back-Cover Texts, in the notice + that says that the Document is released under this License. A + Front-Cover Text may be at most 5 words, and a Back-Cover Text may + be at most 25 words. + + A "Transparent" copy of the Document means a machine-readable copy, + represented in a format whose specification is available to the + general public, that is suitable for revising the document + straightforwardly with generic text editors or (for images + composed of pixels) generic paint programs or (for drawings) some + widely available drawing editor, and that is suitable for input to + text formatters or for automatic translation to a variety of + formats suitable for input to text formatters. A copy made in an + otherwise Transparent file format whose markup, or absence of + markup, has been arranged to thwart or discourage subsequent + modification by readers is not Transparent. An image format is + not Transparent if used for any substantial amount of text. A + copy that is not "Transparent" is called "Opaque". + + Examples of suitable formats for Transparent copies include plain + ASCII without markup, Texinfo input format, LaTeX input format, + SGML or XML using a publicly available DTD, and + standard-conforming simple HTML, PostScript or PDF designed for + human modification. Examples of transparent image formats include + PNG, XCF and JPG. Opaque formats include proprietary formats that + can be read and edited only by proprietary word processors, SGML or + XML for which the DTD and/or processing tools are not generally + available, and the machine-generated HTML, PostScript or PDF + produced by some word processors for output purposes only. + + The "Title Page" means, for a printed book, the title page itself, + plus such following pages as are needed to hold, legibly, the + material this License requires to appear in the title page. For + works in formats which do not have any title page as such, "Title + Page" means the text near the most prominent appearance of the + work's title, preceding the beginning of the body of the text. + + A section "Entitled XYZ" means a named subunit of the Document + whose title either is precisely XYZ or contains XYZ in parentheses + following text that translates XYZ in another language. (Here XYZ + stands for a specific section name mentioned below, such as + "Acknowledgements", "Dedications", "Endorsements", or "History".) + To "Preserve the Title" of such a section when you modify the + Document means that it remains a section "Entitled XYZ" according + to this definition. + + The Document may include Warranty Disclaimers next to the notice + which states that this License applies to the Document. These + Warranty Disclaimers are considered to be included by reference in + this License, but only as regards disclaiming warranties: any other + implication that these Warranty Disclaimers may have is void and + has no effect on the meaning of this License. + + 2. VERBATIM COPYING + + You may copy and distribute the Document in any medium, either + commercially or noncommercially, provided that this License, the + copyright notices, and the license notice saying this License + applies to the Document are reproduced in all copies, and that you + add no other conditions whatsoever to those of this License. You + may not use technical measures to obstruct or control the reading + or further copying of the copies you make or distribute. However, + you may accept compensation in exchange for copies. If you + distribute a large enough number of copies you must also follow + the conditions in section 3. + + You may also lend copies, under the same conditions stated above, + and you may publicly display copies. + + 3. COPYING IN QUANTITY + + If you publish printed copies (or copies in media that commonly + have printed covers) of the Document, numbering more than 100, and + the Document's license notice requires Cover Texts, you must + enclose the copies in covers that carry, clearly and legibly, all + these Cover Texts: Front-Cover Texts on the front cover, and + Back-Cover Texts on the back cover. Both covers must also clearly + and legibly identify you as the publisher of these copies. The + front cover must present the full title with all words of the + title equally prominent and visible. You may add other material + on the covers in addition. Copying with changes limited to the + covers, as long as they preserve the title of the Document and + satisfy these conditions, can be treated as verbatim copying in + other respects. + + If the required texts for either cover are too voluminous to fit + legibly, you should put the first ones listed (as many as fit + reasonably) on the actual cover, and continue the rest onto + adjacent pages. + + If you publish or distribute Opaque copies of the Document + numbering more than 100, you must either include a + machine-readable Transparent copy along with each Opaque copy, or + state in or with each Opaque copy a computer-network location from + which the general network-using public has access to download + using public-standard network protocols a complete Transparent + copy of the Document, free of added material. If you use the + latter option, you must take reasonably prudent steps, when you + begin distribution of Opaque copies in quantity, to ensure that + this Transparent copy will remain thus accessible at the stated + location until at least one year after the last time you + distribute an Opaque copy (directly or through your agents or + retailers) of that edition to the public. + + It is requested, but not required, that you contact the authors of + the Document well before redistributing any large number of + copies, to give them a chance to provide you with an updated + version of the Document. + + 4. MODIFICATIONS + + You may copy and distribute a Modified Version of the Document + under the conditions of sections 2 and 3 above, provided that you + release the Modified Version under precisely this License, with + the Modified Version filling the role of the Document, thus + licensing distribution and modification of the Modified Version to + whoever possesses a copy of it. In addition, you must do these + things in the Modified Version: + + A. Use in the Title Page (and on the covers, if any) a title + distinct from that of the Document, and from those of + previous versions (which should, if there were any, be listed + in the History section of the Document). You may use the + same title as a previous version if the original publisher of + that version gives permission. + + B. List on the Title Page, as authors, one or more persons or + entities responsible for authorship of the modifications in + the Modified Version, together with at least five of the + principal authors of the Document (all of its principal + authors, if it has fewer than five), unless they release you + from this requirement. + + C. State on the Title page the name of the publisher of the + Modified Version, as the publisher. + + D. Preserve all the copyright notices of the Document. + + E. Add an appropriate copyright notice for your modifications + adjacent to the other copyright notices. + + F. Include, immediately after the copyright notices, a license + notice giving the public permission to use the Modified + Version under the terms of this License, in the form shown in + the Addendum below. + + G. Preserve in that license notice the full lists of Invariant + Sections and required Cover Texts given in the Document's + license notice. + + H. Include an unaltered copy of this License. + + I. Preserve the section Entitled "History", Preserve its Title, + and add to it an item stating at least the title, year, new + authors, and publisher of the Modified Version as given on + the Title Page. If there is no section Entitled "History" in + the Document, create one stating the title, year, authors, + and publisher of the Document as given on its Title Page, + then add an item describing the Modified Version as stated in + the previous sentence. + + J. Preserve the network location, if any, given in the Document + for public access to a Transparent copy of the Document, and + likewise the network locations given in the Document for + previous versions it was based on. These may be placed in + the "History" section. You may omit a network location for a + work that was published at least four years before the + Document itself, or if the original publisher of the version + it refers to gives permission. + + K. For any section Entitled "Acknowledgements" or "Dedications", + Preserve the Title of the section, and preserve in the + section all the substance and tone of each of the contributor + acknowledgements and/or dedications given therein. + + L. Preserve all the Invariant Sections of the Document, + unaltered in their text and in their titles. Section numbers + or the equivalent are not considered part of the section + titles. + + M. Delete any section Entitled "Endorsements". Such a section + may not be included in the Modified Version. + + N. Do not retitle any existing section to be Entitled + "Endorsements" or to conflict in title with any Invariant + Section. + + O. Preserve any Warranty Disclaimers. + + If the Modified Version includes new front-matter sections or + appendices that qualify as Secondary Sections and contain no + material copied from the Document, you may at your option + designate some or all of these sections as invariant. To do this, + add their titles to the list of Invariant Sections in the Modified + Version's license notice. These titles must be distinct from any + other section titles. + + You may add a section Entitled "Endorsements", provided it contains + nothing but endorsements of your Modified Version by various + parties--for example, statements of peer review or that the text + has been approved by an organization as the authoritative + definition of a standard. + + You may add a passage of up to five words as a Front-Cover Text, + and a passage of up to 25 words as a Back-Cover Text, to the end + of the list of Cover Texts in the Modified Version. Only one + passage of Front-Cover Text and one of Back-Cover Text may be + added by (or through arrangements made by) any one entity. If the + Document already includes a cover text for the same cover, + previously added by you or by arrangement made by the same entity + you are acting on behalf of, you may not add another; but you may + replace the old one, on explicit permission from the previous + publisher that added the old one. + + The author(s) and publisher(s) of the Document do not by this + License give permission to use their names for publicity for or to + assert or imply endorsement of any Modified Version. + + 5. COMBINING DOCUMENTS + + You may combine the Document with other documents released under + this License, under the terms defined in section 4 above for + modified versions, provided that you include in the combination + all of the Invariant Sections of all of the original documents, + unmodified, and list them all as Invariant Sections of your + combined work in its license notice, and that you preserve all + their Warranty Disclaimers. + + The combined work need only contain one copy of this License, and + multiple identical Invariant Sections may be replaced with a single + copy. If there are multiple Invariant Sections with the same name + but different contents, make the title of each such section unique + by adding at the end of it, in parentheses, the name of the + original author or publisher of that section if known, or else a + unique number. Make the same adjustment to the section titles in + the list of Invariant Sections in the license notice of the + combined work. + + In the combination, you must combine any sections Entitled + "History" in the various original documents, forming one section + Entitled "History"; likewise combine any sections Entitled + "Acknowledgements", and any sections Entitled "Dedications". You + must delete all sections Entitled "Endorsements." + + 6. COLLECTIONS OF DOCUMENTS + + You may make a collection consisting of the Document and other + documents released under this License, and replace the individual + copies of this License in the various documents with a single copy + that is included in the collection, provided that you follow the + rules of this License for verbatim copying of each of the + documents in all other respects. + + You may extract a single document from such a collection, and + distribute it individually under this License, provided you insert + a copy of this License into the extracted document, and follow + this License in all other respects regarding verbatim copying of + that document. + + 7. AGGREGATION WITH INDEPENDENT WORKS + + A compilation of the Document or its derivatives with other + separate and independent documents or works, in or on a volume of + a storage or distribution medium, is called an "aggregate" if the + copyright resulting from the compilation is not used to limit the + legal rights of the compilation's users beyond what the individual + works permit. When the Document is included an aggregate, this + License does not apply to the other works in the aggregate which + are not themselves derivative works of the Document. + + If the Cover Text requirement of section 3 is applicable to these + copies of the Document, then if the Document is less than one half + of the entire aggregate, the Document's Cover Texts may be placed + on covers that bracket the Document within the aggregate, or the + electronic equivalent of covers if the Document is in electronic + form. Otherwise they must appear on printed covers that bracket + the whole aggregate. + + 8. TRANSLATION + + Translation is considered a kind of modification, so you may + distribute translations of the Document under the terms of section + 4. Replacing Invariant Sections with translations requires special + permission from their copyright holders, but you may include + translations of some or all Invariant Sections in addition to the + original versions of these Invariant Sections. You may include a + translation of this License, and all the license notices in the + Document, and any Warrany Disclaimers, provided that you also + include the original English version of this License and the + original versions of those notices and disclaimers. In case of a + disagreement between the translation and the original version of + this License or a notice or disclaimer, the original version will + prevail. + + If a section in the Document is Entitled "Acknowledgements", + "Dedications", or "History", the requirement (section 4) to + Preserve its Title (section 1) will typically require changing the + actual title. + + 9. TERMINATION + + You may not copy, modify, sublicense, or distribute the Document + except as expressly provided for under this License. Any other + attempt to copy, modify, sublicense or distribute the Document is + void, and will automatically terminate your rights under this + License. However, parties who have received copies, or rights, + from you under this License will not have their licenses + terminated so long as such parties remain in full compliance. + + 10. FUTURE REVISIONS OF THIS LICENSE + + The Free Software Foundation may publish new, revised versions of + the GNU Free Documentation License from time to time. Such new + versions will be similar in spirit to the present version, but may + differ in detail to address new problems or concerns. See + `http://www.gnu.org/copyleft/'. + + Each version of the License is given a distinguishing version + number. If the Document specifies that a particular numbered + version of this License "or any later version" applies to it, you + have the option of following the terms and conditions either of + that specified version or of any later version that has been + published (not as a draft) by the Free Software Foundation. If + the Document does not specify a version number of this License, + you may choose any version ever published (not as a draft) by the + Free Software Foundation. + + ADDENDUM: How to use this License for your documents + ==================================================== + + To use this License in a document you have written, include a copy of + the License in the document and put the following copyright and license + notices just after the title page: + + Copyright (C) YEAR YOUR NAME. + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.2 + or any later version published by the Free Software Foundation; + with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. + A copy of the license is included in the section entitled ``GNU + Free Documentation License''. + + If you have Invariant Sections, Front-Cover Texts and Back-Cover + Texts, replace the "with...Texts." line with this: + + with the Invariant Sections being LIST THEIR TITLES, with + the Front-Cover Texts being LIST, and with the Back-Cover Texts + being LIST. + + If you have Invariant Sections without Cover Texts, or some other + combination of the three, merge those two alternatives to suit the + situation. + + If your document contains nontrivial examples of program code, we + recommend releasing these examples in parallel under your choice of + free software license, such as the GNU General Public License, to + permit their use in free software. + +  + File: gnat_rm.info, Node: Index, Prev: GNU Free Documentation License, Up: Top + + Index + ***** + + * Menu: + + * -gnatR switch: Determining the Representations chosen by GNAT. + * Abort_Defer: Implementation Defined Pragmas. + * Abort_Signal: Implementation Defined Attributes. + * Access, unrestricted: Implementation Defined Attributes. + * Accuracy requirements: Implementation Advice. + * Accuracy, complex arithmetic: Implementation Advice. + * Ada 83 attributes: Implementation Defined Attributes. + * Ada 95 ISO/ANSI Standard: What This Reference Manual Contains. + * Ada.Characters.Handling: Implementation Advice. + * Ada.Characters.Latin_9 (a-chlat9.ads): Ada.Characters.Latin_9 (a-chlat9.ads). + * Ada.Characters.Wide_Latin_1 (a-cwila1.ads): Ada.Characters.Wide_Latin_1 (a-cwila1.ads). + * Ada.Characters.Wide_Latin_9 (a-cwila1.ads): Ada.Characters.Wide_Latin_9 (a-cwila9.ads). + * Ada.Command_Line.Remove (a-colire.ads): Ada.Command_Line.Remove (a-colire.ads). + * Ada.Direct_IO.C_Streams (a-diocst.ads): Ada.Direct_IO.C_Streams (a-diocst.ads). + * Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads): Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads). + * Ada.Sequential_IO.C_Streams (a-siocst.ads): Ada.Sequential_IO.C_Streams (a-siocst.ads). + * Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads): Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads). + * Ada.Strings.Unbounded.Text_IO (a-suteio.ads): Ada.Strings.Unbounded.Text_IO (a-suteio.ads). + * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads): Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads). + * Ada.Text_IO.C_Streams (a-tiocst.ads): Ada.Text_IO.C_Streams (a-tiocst.ads). + * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads): Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads). + * Ada_83: Implementation Defined Pragmas. + * Ada_95: Implementation Defined Pragmas. + * Address Clause: Address Clauses. + * Address clauses: Implementation Advice. + * Address image: System.Address_Image (s-addima.ads). + * Address of subprogram code: Implementation Defined Attributes. + * Address, as private type: Implementation Advice. + * Address, operations of: Implementation Advice. + * Address_Size: Implementation Defined Attributes. + * Alignment Clause: Alignment Clauses. + * Alignment clauses: Implementation Advice. + * Alignment, default: Alignment Clauses. + * Alignment, maximum: Implementation Defined Attributes. + * Alignments of components: Implementation Defined Pragmas. + * Alternative Character Sets: Implementation Advice. + * Annotate: Implementation Defined Pragmas. + * Argument passing mechanisms: Implementation Defined Pragmas. + * Arrays, extendable <1>: GNAT.Table (g-table.ads). + * Arrays, extendable: GNAT.Dynamic_Tables (g-dyntab.ads). + * Arrays, multidimensional: Implementation Advice. + * Asm_Input: Implementation Defined Attributes. + * Asm_Output: Implementation Defined Attributes. + * Assert: Implementation Defined Pragmas. + * Assert_Failure, exception: System.Assertions (s-assert.ads). + * Assertions: System.Assertions (s-assert.ads). + * AST_Entry: Implementation Defined Attributes. + * Ast_Entry: Implementation Defined Pragmas. + * Attribute: Address Clauses. + * AWK: GNAT.AWK (g-awk.ads). + * Biased representation: Biased Representation. + * Big endian: Implementation Defined Attributes. + * Bit: Implementation Defined Attributes. + * bit ordering: Bit_Order Clauses. + * Bit ordering: Implementation Advice. + * Bit_Order Clause: Bit_Order Clauses. + * Bit_Position: Implementation Defined Attributes. + * Boolean_Entry_Barriers: Implementation Defined Characteristics. + * Bounded errors: Implementation Advice. + * Bounded-length strings: Implementation Advice. + * Bubble sort <1>: GNAT.Bubble_Sort_G (g-busorg.ads). + * Bubble sort: GNAT.Bubble_Sort_A (g-busora.ads). + * byte ordering: Effect of Bit_Order on Byte Ordering. + * C streams, interfacing: Interfaces.C.Streams (i-cstrea.ads). + * C Streams, Interfacing with Direct_IO: Ada.Direct_IO.C_Streams (a-diocst.ads). + * C Streams, Interfacing with Sequential_IO: Ada.Sequential_IO.C_Streams (a-siocst.ads). + * C Streams, Interfacing with Stream_IO: Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads). + * C Streams, Interfacing with Text_IO: Ada.Text_IO.C_Streams (a-tiocst.ads). + * C Streams, Interfacing with Wide_Text_IO: Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads). + * C++ interfacing: Interfaces.CPP (i-cpp.ads). + * C, interfacing with: Implementation Advice. + * C_Pass_By_Copy: Implementation Defined Pragmas. + * Calendar <1>: GNAT.Calendar.Time_IO (g-catiio.ads). + * Calendar: GNAT.Calendar (g-calend.ads). + * Casing of External names: Implementation Defined Pragmas. + * Casing utilities: GNAT.Case_Util (g-casuti.ads). + * CGI (Common Gateway Interface): GNAT.CGI (g-cgi.ads). + * CGI (Common Gateway Interface) cookie support: GNAT.CGI.Cookie (g-cgicoo.ads). + * CGI (Common Gateway Interface) debugging: GNAT.CGI.Debug (g-cgideb.ads). + * Character handling (GNAT.Case_Util): GNAT.Case_Util (g-casuti.ads). + * Character Sets: Implementation Advice. + * Checks, suppression of: Implementation Advice. + * Child Units: Implementation Advice. + * COBOL support: Implementation Advice. + * COBOL, interfacing with: Implementation Advice. + * Code_Address: Implementation Defined Attributes. + * Command line: GNAT.Command_Line (g-comlin.ads). + * Command line, argument removal: Ada.Command_Line.Remove (a-colire.ads). + * Comment: Implementation Defined Pragmas. + * Common_Object: Implementation Defined Pragmas. + * Compatibility (between Ada 83 and Ada 95): Compatibility with Ada 83. + * Complex arithmetic accuracy: Implementation Advice. + * Complex elementary functions: Implementation Advice. + * Complex types: Implementation Advice. + * Complex_Representation: Implementation Defined Pragmas. + * Component Clause: Record Representation Clauses. + * Component_Alignment: Implementation Defined Pragmas. + * Component_Size: Implementation Defined Pragmas. + * Component_Size Clause: Component_Size Clauses. + * Component_Size clauses: Implementation Advice. + * Component_Size_4: Implementation Defined Pragmas. + * Convention, effect on representation: Effect of Convention on Representation. + * Convention_Identifier: Implementation Defined Pragmas. + * Conventions, synonyms: Implementation Defined Pragmas. + * Conventions, typographical: Conventions. + * Cookie support in CGI: GNAT.CGI.Cookie (g-cgicoo.ads). + * CPP_Class: Implementation Defined Pragmas. + * CPP_Constructor: Implementation Defined Pragmas. + * CPP_Virtual: Implementation Defined Pragmas. + * CPP_Vtable: Implementation Defined Pragmas. + * CRC32: GNAT.CRC32 (g-crc32.ads). + * Current exception: GNAT.Current_Exception (g-curexc.ads). + * Cyclic Redundancy Check: GNAT.CRC32 (g-crc32.ads). + * Debug: Implementation Defined Pragmas. + * Debug pools: GNAT.Debug_Pools (g-debpoo.ads). + * Debugging <1>: GNAT.Exception_Traces (g-exctra.ads). + * Debugging <2>: GNAT.Debug_Utilities (g-debuti.ads). + * Debugging: GNAT.Debug_Pools (g-debpoo.ads). + * debugging with Initialize_Scalars: Implementation Defined Pragmas. + * Dec Ada 83: Implementation Defined Pragmas. + * Dec Ada 83 casing compatibility: Implementation Defined Pragmas. + * Decimal radix support: Implementation Advice. + * Default_Bit_Order: Implementation Defined Attributes. + * Deferring aborts: Implementation Defined Pragmas. + * Directory operations: GNAT.Directory_Operations (g-dirope.ads). + * Discriminants, testing for: Implementation Defined Attributes. + * Duration'Small: Implementation Advice. + * Elab_Body: Implementation Defined Attributes. + * Elab_Spec: Implementation Defined Attributes. + * Elaborated: Implementation Defined Attributes. + * Elaboration control: Implementation Defined Pragmas. + * Elaboration_Checks: Implementation Defined Pragmas. + * Eliminate: Implementation Defined Pragmas. + * Elimination of unused subprograms: Implementation Defined Pragmas. + * Emax: Implementation Defined Attributes. + * Enclosing_Entity: Enclosing_Entity. + * Entry queuing policies: Implementation Advice. + * Enum_Rep: Implementation Defined Attributes. + * Enumeration representation clauses: Implementation Advice. + * Enumeration values: Implementation Advice. + * Epsilon: Implementation Defined Attributes. + * Error detection: Implementation Advice. + * Exception information: Implementation Advice. + * Exception retrieval: GNAT.Current_Exception (g-curexc.ads). + * Exception traces: GNAT.Exception_Traces (g-exctra.ads). + * Exception, obtaining most recent: GNAT.Most_Recent_Exception (g-moreex.ads). + * Exception_Information': Exception_Information. + * Exception_Message: Exception_Message. + * Exception_Name: Exception_Name. + * Export <1>: Address Clauses. + * Export: Implementation Advice. + * Export_Exception: Implementation Defined Pragmas. + * Export_Function: Implementation Defined Pragmas. + * Export_Object: Implementation Defined Pragmas. + * Export_Procedure: Implementation Defined Pragmas. + * Export_Valued_Procedure: Implementation Defined Pragmas. + * Extend_System: Implementation Defined Pragmas. + * External: Implementation Defined Pragmas. + * External Names, casing: Implementation Defined Pragmas. + * External_Name_Casing: Implementation Defined Pragmas. + * FDL, GNU Free Documentation License: GNU Free Documentation License. + * File: File. + * File locking: GNAT.Lock_Files (g-locfil.ads). + * Finalize_Storage_Only: Implementation Defined Pragmas. + * Fixed_Value: Implementation Defined Attributes. + * Float types: Implementation Advice. + * Float_Representation: Implementation Defined Pragmas. + * Floating-Point Processor: GNAT.Float_Control (g-flocon.ads). + * Foreign threads: GNAT.Threads (g-thread.ads). + * Fortran, interfacing with: Implementation Advice. + * Get_Immediate <1>: Get_Immediate. + * Get_Immediate: Implementation Advice. + * GNAT.AWK (g-awk.ads): GNAT.AWK (g-awk.ads). + * GNAT.Bubble_Sort_A (g-busora.ads): GNAT.Bubble_Sort_A (g-busora.ads). + * GNAT.Bubble_Sort_G (g-busorg.ads): GNAT.Bubble_Sort_G (g-busorg.ads). + * GNAT.Calendar (g-calend.ads): GNAT.Calendar (g-calend.ads). + * GNAT.Calendar.Time_IO (g-catiio.ads): GNAT.Calendar.Time_IO (g-catiio.ads). + *