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_wi