diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 26 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/s-finmas.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/s-finmas.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/s-stposu.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/s-taenca.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/s-tasren.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/s-tpoben.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/s-tpoben.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/s-tpobop.adb | 6 |
12 files changed, 102 insertions, 31 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b4ddbf39634..e80bae811db 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,31 @@ 2011-09-05 Hristian Kirtchev <kirtchev@adacore.com> + * s-finmas.adb (Set_Finalize_Address): Explain the reason + for the synchronization. Move the test for null from + s-stposu.Allocate_Any_Controlled to this routine since the check + needs to be protected too. + (Set_Heterogeneous_Finalize_Address): Explain the reason for the + synchronization code. + * s-finmas.ads (Set_Heterogeneous_Finalize_Address): Add comment + explaining the context in which this routine is used. + * s-stposu.adb (Allocate_Any_Controlled): Move the test for null + to s-finmas.Set_Finalize_Address. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads: Document that itypes have no parent field. + +2011-09-05 Robert Dewar <dewar@adacore.com> + + * rtsfind.adb (Check_CRT): Check for overloaded entity + * rtsfind.ads: Document that entities to be found by rtsfind + cannot be overloaded + * s-taenca.adb, s-tasren.adb, s-tpobop.adb, s-tpoben.ads, s-tpoben.adb + (Lock_Entries_With_Status): New name for Lock_Entries with two + arguments (changed to meet rtsfind no overloading rule). + +2011-09-05 Hristian Kirtchev <kirtchev@adacore.com> + * s-finmas.adb (Set_Finalize_Address (Address, Finalize_Address_Ptr)): Renamed to Set_Heterogeneous_Finalize_Address. (Set_Finalize_Address (in out Finalization_Master, diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c2657dc3264..001e49b032a 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -442,6 +442,11 @@ package Einfo is -- declaration, the associated_node_for_itype is the discriminant -- specification. For an access parameter it is the enclosing subprogram -- declaration. +-- +-- Itypes have no explicit declaration, and therefore are not attached to +-- the tree: their Parent field is always empty. The Associated_Node_For_ +-- Itype is the only way to determine the construct that leads to the +-- creation of a given itype entity. -- Associated_Storage_Pool (Node22) [root type only] -- Present in simple and general access type entities. References the diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index bb963d097e8..459f886dcc9 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -135,7 +135,7 @@ package body Rtsfind is -- Check entity Eid to ensure that configurable run-time restrictions are -- met. May generate an error message (if RTE_Available_Call is false) and -- raise RE_Not_Available if entity E does not exist (e.g. Eid is Empty). - -- Above documentation not clear ??? + -- Also check that entity is not overloaded. procedure Entity_Not_Defined (Id : RE_Id); -- Outputs error messages for an entity that is not defined in the run-time @@ -233,6 +233,22 @@ package body Rtsfind is raise RE_Not_Available; end if; + -- Check entity is not overloaded, checking for special exceptions + + if Has_Homonym (Eid) + and then E /= RE_Save_Occurrence + then + Set_Standard_Error; + Write_Str ("Run-time configuration error ("); + Write_Str ("rtsfind entity """); + Get_Decoded_Name_String (Chars (Eid)); + Set_Casing (Mixed_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str (""" is overloaded)"); + Write_Eol; + raise Unrecoverable_Error; + end if; + -- Otherwise entity is accessible return Eid; @@ -414,8 +430,8 @@ package body Rtsfind is return E1 = E2; end if; - -- If the unit containing E is not loaded, we already know that - -- the entity we have cannot have come from this unit. + -- If the unit containing E is not loaded, we already know that the + -- entity we have cannot have come from this unit. E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E)); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index bc5556904fc..7b772d021c4 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -498,6 +498,14 @@ package Rtsfind is -- value is required syntactically, but no real entry is required or -- needed. Use of this value will cause a fatal error in an RTE call. + -- Note that under no circumstances can any of these entities be defined + -- more than once in a given package, i.e. no overloading is allowed for + -- any entity that is found using rtsfind. A fatal error is given if this + -- rule is violated. The one exception is for Save_Occurrence, where the + -- RM mandates the overloading. In this case, the compiler only uses the + -- procedure, not the function, and the procedure must come first so that + -- the compiler finds it and not the function. + type RE_Id is ( RE_Null, diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index cfeb816a374..c663988f43a 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -463,8 +463,17 @@ package body System.Finalization_Masters is Fin_Addr_Ptr : Finalize_Address_Ptr) is begin + -- TSS primitive Finalize_Address is set at the point of allocation, + -- either through Allocate_Any_Controlled or through this routine. + -- Since multiple tasks can allocate on the same finalization master, + -- access to this attribute must be protected. + Lock_Task.all; - Master.Finalize_Address := Fin_Addr_Ptr; + + if Master.Finalize_Address = null then + Master.Finalize_Address := Fin_Addr_Ptr; + end if; + Unlock_Task.all; end Set_Finalize_Address; @@ -477,6 +486,9 @@ package body System.Finalization_Masters is Fin_Addr_Ptr : Finalize_Address_Ptr) is begin + -- Protected access is required in this case because + -- Finalize_Address_Table is a global data structure. + Lock_Task.all; Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); Unlock_Task.all; diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads index fc4d143b00e..bb9ff5bdc3c 100644 --- a/gcc/ada/s-finmas.ads +++ b/gcc/ada/s-finmas.ads @@ -124,7 +124,10 @@ package System.Finalization_Masters is procedure Set_Heterogeneous_Finalize_Address (Obj : System.Address; Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Add a relation pair object - Finalize_Address to the internal hash table + -- Add a relation pair object - Finalize_Address to the internal hash + -- table. This is done in the context of allocation on a heterogeneous + -- finalization master where a single master services multiple anonymous + -- access-to-controlled types. procedure Set_Is_Heterogeneous (Master : in out Finalization_Master); -- Mark the master as being a heterogeneous collection of objects diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 4fbacfac3b3..b8ad53d613b 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -276,9 +276,7 @@ package body System.Storage_Pools.Subpools is -- 3) Most cases of anonymous access types usage if Master.Is_Homogeneous then - if Finalize_Address (Master.all) = null then - Set_Finalize_Address (Master.all, Fin_Address); - end if; + Set_Finalize_Address (Master.all, Fin_Address); -- Heterogeneous masters service the following: diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb index 14812a4464d..b1e9b640ba8 100644 --- a/gcc/ada/s-taenca.adb +++ b/gcc/ada/s-taenca.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -216,7 +216,7 @@ package body System.Tasking.Entry_Calls is STPO.Unlock_RTS; end if; - Lock_Entries (Test_PO, Ceiling_Violation); + Lock_Entries_With_Status (Test_PO, Ceiling_Violation); -- ??? diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 0958a8dbf32..4034e61af17 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -628,7 +628,7 @@ package body System.Tasking.Rendezvous is -- Requeue to a protected entry Called_PO := POE.To_Protection (Entry_Call.Called_PO); - STPE.Lock_Entries (Called_PO, Ceiling_Violation); + STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation); if Ceiling_Violation then pragma Assert (Ex = Ada.Exceptions.Null_Id); diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index ba2bf6c267a..88527315e42 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -261,7 +261,22 @@ package body System.Tasking.Protected_Objects.Entries is -- Lock_Entries -- ------------------ - procedure Lock_Entries + procedure Lock_Entries (Object : Protection_Entries_Access) is + Ceiling_Violation : Boolean; + + begin + Lock_Entries_With_Status (Object, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error with "Ceiling Violation"; + end if; + end Lock_Entries; + + ------------------------------ + -- Lock_Entries_With_Status -- + ------------------------------ + + procedure Lock_Entries_With_Status (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is @@ -316,19 +331,7 @@ package body System.Tasking.Protected_Objects.Entries is Self_Id.Common.Protected_Action_Nesting + 1; end; end if; - - end Lock_Entries; - - procedure Lock_Entries (Object : Protection_Entries_Access) is - Ceiling_Violation : Boolean; - - begin - Lock_Entries (Object, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error with "Ceiling Violation"; - end if; - end Lock_Entries; + end Lock_Entries_With_Status; ---------------------------- -- Lock_Read_Only_Entries -- diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads index b0be2526c45..ce7045cf56e 100644 --- a/gcc/ada/s-tpoben.ads +++ b/gcc/ada/s-tpoben.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -183,7 +183,7 @@ package System.Tasking.Protected_Objects.Entries is -- Unlock has been made by the caller. Program_Error is raised in case of -- ceiling violation. - procedure Lock_Entries + procedure Lock_Entries_With_Status (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean); -- Same as above, but return the ceiling violation status instead of diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 8aeabc2efbb..171c771ed61 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -568,7 +568,7 @@ package body System.Tasking.Protected_Objects.Operations is -- where abort is already deferred. Initialization.Defer_Abort_Nestable (Self_ID); - Lock_Entries (Object, Ceiling_Violation); + Lock_Entries_With_Status (Object, Ceiling_Violation); if Ceiling_Violation then @@ -722,7 +722,7 @@ package body System.Tasking.Protected_Objects.Operations is -- Requeue is to different PO - Lock_Entries (New_Object, Ceiling_Violation); + Lock_Entries_With_Status (New_Object, Ceiling_Violation); if Ceiling_Violation then Object.Call_In_Progress := null; @@ -966,7 +966,7 @@ package body System.Tasking.Protected_Objects.Operations is end if; Initialization.Defer_Abort_Nestable (Self_Id); - Lock_Entries (Object, Ceiling_Violation); + Lock_Entries_With_Status (Object, Ceiling_Violation); if Ceiling_Violation then Initialization.Undefer_Abort (Self_Id); |