diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/ada/a-cbhase.adb | 88 | ||||
| -rw-r--r-- | gcc/ada/a-cbhase.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/a-cbmutr.adb | 72 | ||||
| -rw-r--r-- | gcc/ada/a-cbmutr.ads | 63 | ||||
| -rw-r--r-- | gcc/ada/a-chtgbo.adb | 44 | ||||
| -rw-r--r-- | gcc/ada/a-chtgbo.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/clean.adb | 42 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 2 |
9 files changed, 286 insertions, 86 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2141f0bb0d5..96e883dd9e5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,28 @@ 2014-07-30 Robert Dewar <dewar@adacore.com> + * clean.adb: Minor reformatting. + * opt.ads: Minor fix to incorrect comment. + +2014-07-30 Ed Schonberg <schonberg@adacore.com> + + * a-chtgbo.ads, a-chtgbo.adb (Delete_Node_At_Index): New + subprogram, used by bounded hashed sets, to delete a node at + a given index, whose element may have been improperly updated + through a Reference_Preserving key. + * a-cbhase.ads: Add Reference_Control_Type to package Generic_Keys. + * a-cbhase.adb: Add Adjust and Finalize routines for + Reference_Control_Type. + (Delete, Insert): Raise Program_Error, not Constraint_Error, + when operation is illegal. + (Reference_Preserving_Key): Build aggregate for Reference_Control_Type + * a-cmbutr.ads: Add Reference_Control_Type to detect tampering. Add + private with_clause for Ada.Finalization. + * a-cbmutr.adb: Add Adjust and Finalize routines for + Reference_Control_Type. Use it in the construction of Reference + and Constant_Reference values. + +2014-07-30 Robert Dewar <dewar@adacore.com> + * sem_ch3.adb, sem_ch3.ads: Minor code reorganization. 2014-07-30 Pascal Obry <obry@adacore.com> diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 6ea8e0ad0ef..65cf7f7d788 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- -- -- GNAT LIBRARY COMPONENTS -- -- -- @@ -313,7 +313,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Element_Keys.Delete_Key_Sans_Free (Container, Item, X); if X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; + raise Program_Error with "attempt to delete element not in set"; end if; HT_Ops.Free (Container, X); @@ -762,7 +762,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - raise Constraint_Error with + raise Program_Error with "attempt to insert element already in set"; end if; end Insert; @@ -1621,6 +1621,23 @@ package body Ada.Containers.Bounded_Hashed_Sets is -- Local Subprograms -- ----------------------- + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + B : Natural renames Control.Container.Busy; + L : Natural renames Control.Container.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Type) return Boolean; @@ -1751,6 +1768,32 @@ package body Ada.Containers.Bounded_Hashed_Sets is HT_Ops.Free (Container, X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + B : Natural renames Control.Container.Busy; + L : Natural renames Control.Container.Lock; + begin + B := B - 1; + L := L - 1; + end; + + if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + then + HT_Ops.Delete_Node_At_Index + (Control.Container.all, Control.Index, Control.Old_Pos.Node); + raise Program_Error with "key not preserved in reference"; + end if; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1815,14 +1858,25 @@ package body Ada.Containers.Bounded_Hashed_Sets is (Vet (Position), "bad cursor in function Reference_Preserving_Key"); - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? - declare N : Node_Type renames Container.Nodes (Position.Node); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + begin - return (Element => N.Element'Access); + return R : constant Reference_Type := + (Element => N.Element'Unrestricted_Access, + Control => + (Controlled with + Container'Unrestricted_Access, + Index => + Key_Keys.Index (Container, Key (Position)), + Old_Pos => Position, + Old_Hash => Hash (Key (Position)))) + do + B := B + 1; + L := L + 1; + end return; end; end Reference_Preserving_Key; @@ -1838,9 +1892,23 @@ package body Ada.Containers.Bounded_Hashed_Sets is end if; declare - N : Node_Type renames Container.Nodes (Node); + P : constant Cursor := Find (Container, Key); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + begin - return (Element => N.Element'Access); + return R : constant Reference_Type := + (Element => Container.Nodes (Node).Element'Unrestricted_Access, + Control => + (Controlled with + Container'Unrestricted_Access, + Index => Key_Keys.Index (Container, Key), + Old_Pos => P, + Old_Hash => Hash (Key))) + do + B := B + 1; + L := L + 1; + end return; end; end Reference_Preserving_Key; diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads index 40eea2f0efb..551e84133c0 100644 --- a/gcc/ada/a-cbhase.ads +++ b/gcc/ada/a-cbhase.ads @@ -444,8 +444,29 @@ package Ada.Containers.Bounded_Hashed_Sets is Key : Key_Type) return Reference_Type; private - type Reference_Type (Element : not null access Element_Type) is - null record; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Reference_Control_Type is + new Ada.Finalization.Controlled with + record + Container : Set_Access; + Index : Hash_Type; + Old_Pos : Cursor; + Old_Hash : Hash_Type; + end record; + + overriding procedure + Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure + Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; use Ada.Streams; diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index 1745528d93a..26b0085b648 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -27,8 +27,6 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with Ada.Finalization; use Ada.Finalization; - with System; use type System.Address; package body Ada.Containers.Bounded_Multiway_Trees is @@ -236,6 +234,24 @@ package body Ada.Containers.Bounded_Multiway_Trees is Right_Subtree => Root_Node (Right)); end "="; + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Tree renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------------- -- Allocate_Node -- ------------------- @@ -329,12 +345,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is raise Constraint_Error with "Position cursor has no element"; end if; - -- Commented-out pending ruling by ARG. ??? - - -- if Position.Container /= Container'Unrestricted_Access then - -- raise Program_Error with "Position cursor not in container"; - -- end if; - -- AI-0136 says to raise PE if Position equals the root node. This does -- not seem correct, as this value is just the limiting condition of the -- search. For now we omit this check, pending a ruling from the ARG. @@ -602,7 +612,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- pragma Assert (Vet (Position), -- "Position cursor in Constant_Reference is bad"); - return (Element => Container.Elements (Position.Node)'Access); + declare + C : Tree renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements (Position.Node)'Access, + Control => (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -1270,6 +1293,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is B := B - 1; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Tree renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -2516,7 +2555,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- pragma Assert (Vet (Position), -- "Position cursor in Constant_Reference is bad"); - return (Element => Container.Elements (Position.Node)'Access); + declare + C : Tree renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Container.Elements (Position.Node)'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; + end Reference; -------------------- diff --git a/gcc/ada/a-cbmutr.ads b/gcc/ada/a-cbmutr.ads index 2403164e8e9..7fe4b4e2ff5 100644 --- a/gcc/ada/a-cbmutr.ads +++ b/gcc/ada/a-cbmutr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2014, 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 -- @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; private with Ada.Streams; +private with Ada.Finalization; generic type Element_Type is private; @@ -137,34 +138,10 @@ package Ada.Containers.Bounded_Multiway_Trees is (Container : Tree; Item : Element_Type) return Cursor; - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Find_In_Subtree this way: - -- - -- function Find_In_Subtree - -- (Container : Tree; - -- Item : Element_Type; - -- Position : Cursor) return Cursor; - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - function Find_In_Subtree (Position : Cursor; Item : Element_Type) return Cursor; - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Ancestor_Find this way: - -- - -- function Ancestor_Find - -- (Container : Tree; - -- Item : Element_Type; - -- Position : Cursor) return Cursor; - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - function Ancestor_Find (Position : Cursor; Item : Element_Type) return Cursor; @@ -284,20 +261,6 @@ package Ada.Containers.Bounded_Multiway_Trees is procedure Previous_Sibling (Position : in out Cursor); - -- This version of the AI: - - -- 10-06-02 AI05-0136-1/07 - - -- declares Iterate_Children this way: - - -- procedure Iterate_Children - -- (Container : Tree; - -- Parent : Cursor; - -- Process : not null access procedure (Position : Cursor)); - - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - procedure Iterate_Children (Parent : Cursor; Process : not null access procedure (Position : Cursor)); @@ -308,6 +271,7 @@ package Ada.Containers.Bounded_Multiway_Trees is private use Ada.Streams; + use Ada.Finalization; No_Node : constant Count_Type'Base := -1; -- Need to document all global declarations such as this ??? @@ -368,8 +332,22 @@ private Position : Cursor); for Cursor'Write use Write; + type Reference_Control_Type is + new Controlled with record + Container : Tree_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -382,7 +360,10 @@ private for Constant_Reference_Type'Read use Read; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index c455741fae8..38f95002254 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -81,6 +81,48 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is HT.Buckets := (others => 0); -- optimize this somehow ??? end Clear; + -------------------------- + -- Delete_Node_At_Index -- + -------------------------- + + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type'Class; + Indx : Hash_Type; + X : Count_Type) + is + Prev : Count_Type; + Curr : Count_Type; + + begin + Prev := HT.Buckets (Indx); + + if Prev = 0 then + raise Program_Error with + "attempt to delete node from empty hash bucket"; + end if; + + if Prev = X then + HT.Buckets (Indx) := Next (HT.Nodes (Prev)); + HT.Length := HT.Length - 1; + return; + end if; + if HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (HT.Nodes (Prev)); + + if Curr = 0 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + Prev := Curr; + end loop; + end Delete_Node_At_Index; + --------------------------- -- Delete_Node_Sans_Free -- --------------------------- diff --git a/gcc/ada/a-chtgbo.ads b/gcc/ada/a-chtgbo.ads index 0e9e9284018..719fae94ef5 100644 --- a/gcc/ada/a-chtgbo.ads +++ b/gcc/ada/a-chtgbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -84,6 +84,17 @@ package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- the nodes, not the buckets array.) Program_Error is raised if the hash -- table is busy. + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type'Class; + Indx : Hash_Type; + X : Count_Type); + + -- Delete a node whose bucket position is known. extracted from following + -- subprogram, but also used directly to remove a node whose element has + -- been modified through a key_preserving reference: in that case we cannot + -- use the value of the element precisely because the current value does + -- not correspond to the hash code that determines its bucket. + procedure Delete_Node_Sans_Free (HT : in out Hash_Table_Type'Class; X : Count_Type); diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 4abbc94b9f3..8b34433e1c9 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -740,11 +740,12 @@ package body Clean is if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then declare Unit : Unit_Index; + begin -- Compare with ALI file names of the project - Unit := Units_Htable.Get_First - (Project_Tree.Units_HT); + Unit := + Units_Htable.Get_First (Project_Tree.Units_HT); while Unit /= No_Unit_Index loop if Unit.File_Names (Impl) /= null and then Unit.File_Names (Impl).Project /= @@ -756,9 +757,10 @@ package body Clean is then Get_Name_String (Unit.File_Names (Impl).File); - Name_Len := Name_Len - - File_Extension - (Name (1 .. Name_Len))'Length; + Name_Len := + Name_Len - + File_Extension + (Name (1 .. Name_Len))'Length; if Name_Buffer (1 .. Name_Len) = Name (1 .. Last - 4) then @@ -772,8 +774,7 @@ package body Clean is (Unit.File_Names (Spec).Project) = Project then - Get_Name_String - (Unit.File_Names (Spec).File); + Get_Name_String (Unit.File_Names (Spec).File); Name_Len := Name_Len - File_Extension @@ -869,7 +870,7 @@ package body Clean is if Project.Object_Directory /= No_Path_Information and then Is_Directory - (Get_Name_String (Project.Object_Directory.Display_Name)) + (Get_Name_String (Project.Object_Directory.Display_Name)) then declare Obj_Dir : constant String := @@ -904,8 +905,9 @@ package body Clean is (Unit.File_Names (Impl).Project, Project)) or else (Unit.File_Names (Spec) /= null - and then In_Extension_Chain - (Unit.File_Names (Spec).Project, Project)) + and then + In_Extension_Chain + (Unit.File_Names (Spec).Project, Project)) then if Unit.File_Names (Impl) /= null then File_Name1 := Unit.File_Names (Impl).File; @@ -942,17 +944,17 @@ package body Clean is declare Asm : constant String := - Assembly_File_Name (Lib_File); + Assembly_File_Name (Lib_File); ALI : constant String := - ALI_File_Name (Lib_File); + ALI_File_Name (Lib_File); Obj : constant String := - Object_File_Name (Lib_File); + Object_File_Name (Lib_File); Adt : constant String := - Tree_File_Name (Lib_File); + Tree_File_Name (Lib_File); Deb : constant String := - Debug_File_Name (File_Name1); + Debug_File_Name (File_Name1); Rep : constant String := - Repinfo_File_Name (File_Name1); + Repinfo_File_Name (File_Name1); Del : Boolean := True; begin @@ -1199,8 +1201,9 @@ package body Clean is end if; if Project.Object_Directory /= No_Path_Information - and then Is_Directory - (Get_Name_String (Project.Object_Directory.Display_Name)) + and then + Is_Directory + (Get_Name_String (Project.Object_Directory.Display_Name)) then Delete_Binder_Generated_Files (Get_Name_String (Project.Object_Directory.Display_Name), @@ -1811,8 +1814,7 @@ package body Clean is declare Prj : constant String := Arg (3 .. Arg'Last); begin - if Prj'Length > 1 and then - Prj (Prj'First) = '=' + if Prj'Length > 1 and then Prj (Prj'First) = '=' then Project_File_Name := new String' diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 8781d97f251..dfb2aac86c4 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -224,7 +224,7 @@ package Opt is -- GNAT Normally, in accordance with (RM 13.9.1 (9-11)) the front end -- assumes that values could have invalid representations, unless it can -- clearly prove that the values are valid. If this switch is set (by - -- pragma Assume_No_Invalid_Values (Off)), then the compiler assumes values + -- pragma Assume_No_Invalid_Values (On)), then the compiler assumes values -- are valid and in range of their representations. This feature is now -- fully enabled in the compiler. |