diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2015-10-20 10:23:46 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2015-10-20 10:23:46 +0000 |
| commit | aae9bc79154afb2fc82da451745affd9f0dd1166 (patch) | |
| tree | 5d28f19aa90d6e4079a4f3107278c6be82f787be /gcc/ada | |
| parent | a738763ee9394321fa868afd00cdf04a9a75840f (diff) | |
| download | gcc-aae9bc79154afb2fc82da451745affd9f0dd1166.tar.gz | |
2015-10-20 Bob Duff <duff@adacore.com>
* sem_ch13.adb (Analyze_One_Aspect): Avoid
analyzing the expression in a 'Disable_Controlled attribute when
Expander_Active is False, because otherwise, we get errors about
nonstatic expressions in pragma-Preelaborate generic packages.
* restrict.ads: minor whitespace cleanup in comment
2015-10-20 Bob Duff <duff@adacore.com>
* a-conhel.adb: Remove "use SAC;", because otherwise the compiler
complains about use clauses in run-time units. Use "use type"
instead.
* a-btgbso.adb, a-btgbso.ads, a-cbdlli.adb, a-cbdlli.ads,
* a-cbhama.adb, a-cbhama.ads, a-cbhase.adb, a-cbhase.ads,
* a-cbmutr.adb, a-cbmutr.ads, a-cborma.adb, a-cborma.ads,
* a-cborse.adb, a-cborse.ads, a-cdlili.adb, a-cdlili.ads,
* a-chtgbk.adb, a-chtgbk.ads, a-chtgbo.adb, a-chtgbo.ads,
* a-chtgke.adb, a-chtgke.ads, a-chtgop.adb, a-chtgop.ads,
* a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads,
* a-cihase.adb, a-cihase.ads, a-cimutr.adb, a-cimutr.ads,
* a-ciorma.adb, a-ciorma.ads, a-ciormu.adb, a-ciormu.ads,
* a-ciorse.adb, a-ciorse.ads, a-cobove.adb, a-cobove.ads,
* a-cohama.adb, a-cohama.ads, a-cohase.adb, a-cohase.ads,
* a-cohata.ads, a-coinve.adb, a-comutr.adb, a-comutr.ads,
* a-convec.adb, a-coorma.adb, a-coorma.ads, a-coormu.adb,
* a-coormu.ads, a-coorse.adb, a-coorse.ads, a-crbltr.ads,
* a-crbtgk.adb, a-crbtgk.ads, a-crbtgo.adb, a-crbtgo.ads,
* a-rbtgbk.adb, a-rbtgbk.ads, a-rbtgbo.adb, a-rbtgbo.ads,
* a-rbtgso.adb, a-rbtgso.ads: Change all the predefined containers
to share the tampering machinery in Ada.Containers.Helpers. This
reduces the amount of duplicated code, and takes advantage of
efficiency improvements in Helpers.
Protect all run-time checks and supporting machinery with "if
Checks" or "if T_Check", so this code can be suppressed with
pragma Suppress or -gnatp.
Add Pseudo_Reference and Get_Element_Access to remaining
containers, so that the compiler can optimize "for ... of" loops.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@229041 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
70 files changed, 3839 insertions, 7641 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 773b6a128f0..76f4dd6e47f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,44 @@ 2015-10-20 Bob Duff <duff@adacore.com> + * sem_ch13.adb (Analyze_One_Aspect): Avoid + analyzing the expression in a 'Disable_Controlled attribute when + Expander_Active is False, because otherwise, we get errors about + nonstatic expressions in pragma-Preelaborate generic packages. + * restrict.ads: minor whitespace cleanup in comment + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-conhel.adb: Remove "use SAC;", because otherwise the compiler + complains about use clauses in run-time units. Use "use type" + instead. + * a-btgbso.adb, a-btgbso.ads, a-cbdlli.adb, a-cbdlli.ads, + * a-cbhama.adb, a-cbhama.ads, a-cbhase.adb, a-cbhase.ads, + * a-cbmutr.adb, a-cbmutr.ads, a-cborma.adb, a-cborma.ads, + * a-cborse.adb, a-cborse.ads, a-cdlili.adb, a-cdlili.ads, + * a-chtgbk.adb, a-chtgbk.ads, a-chtgbo.adb, a-chtgbo.ads, + * a-chtgke.adb, a-chtgke.ads, a-chtgop.adb, a-chtgop.ads, + * a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads, + * a-cihase.adb, a-cihase.ads, a-cimutr.adb, a-cimutr.ads, + * a-ciorma.adb, a-ciorma.ads, a-ciormu.adb, a-ciormu.ads, + * a-ciorse.adb, a-ciorse.ads, a-cobove.adb, a-cobove.ads, + * a-cohama.adb, a-cohama.ads, a-cohase.adb, a-cohase.ads, + * a-cohata.ads, a-coinve.adb, a-comutr.adb, a-comutr.ads, + * a-convec.adb, a-coorma.adb, a-coorma.ads, a-coormu.adb, + * a-coormu.ads, a-coorse.adb, a-coorse.ads, a-crbltr.ads, + * a-crbtgk.adb, a-crbtgk.ads, a-crbtgo.adb, a-crbtgo.ads, + * a-rbtgbk.adb, a-rbtgbk.ads, a-rbtgbo.adb, a-rbtgbo.ads, + * a-rbtgso.adb, a-rbtgso.ads: Change all the predefined containers + to share the tampering machinery in Ada.Containers.Helpers. This + reduces the amount of duplicated code, and takes advantage of + efficiency improvements in Helpers. + Protect all run-time checks and supporting machinery with "if + Checks" or "if T_Check", so this code can be suppressed with + pragma Suppress or -gnatp. + Add Pseudo_Reference and Get_Element_Access to remaining + containers, so that the compiler can optimize "for ... of" loops. + +2015-10-20 Bob Duff <duff@adacore.com> + * a-contai.adb, a-coinve.ads, a-contai.ads, a-conhel.adb, a-conhel.ads, Makefile.rtl, a-convec.ads: Move helper code from Ada.Containers to a new package Ada.Containers.Helpers, because otherwise it's not diff --git a/gcc/ada/a-btgbso.adb b/gcc/ada/a-btgbso.adb index 2aef270f64d..363b77e349a 100644 --- a/gcc/ada/a-btgbso.adb +++ b/gcc/ada/a-btgbso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,10 @@ with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -53,12 +57,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ---------------- procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt, Src : Count_Type; TN : Nodes_Type renames Target.Nodes; @@ -68,10 +66,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is begin if Target'Address = Source'Address then - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); Tree_Operations.Clear_Tree (Target); return; @@ -81,10 +76,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); Tgt := Target.First; Src := Source.First; @@ -100,13 +92,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (TN (Tgt), SN (Src)) then Compare := -1; elsif Is_Less (SN (Src), TN (Tgt)) then @@ -114,21 +103,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -171,11 +145,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; @@ -184,12 +155,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -228,21 +193,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is R_Node := Tree_Operations.Next (Right, R_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end return; end Set_Difference; @@ -255,12 +205,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is (Target : in out Set_Type; Source : Set_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Count_Type; Src : Count_Type; @@ -271,10 +215,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); if Source.Length = 0 then Tree_Operations.Clear_Tree (Target); @@ -289,13 +230,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then Compare := -1; elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then @@ -303,21 +241,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -363,11 +286,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; @@ -376,12 +296,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -410,21 +324,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is R_Node := Tree_Operations.Next (Right, R_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end return; end Set_Intersection; @@ -450,42 +349,27 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Subset'Unrestricted_Access.Busy; - LL : Natural renames Subset'Unrestricted_Access.Lock; - - BR : Natural renames Of_Set'Unrestricted_Access.Busy; - LR : Natural renames Of_Set'Unrestricted_Access.Lock; + Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); + Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); Subset_Node : Count_Type; Set_Node : Count_Type; - - Result : Boolean; - begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - Subset_Node := Subset.First; Set_Node := Of_Set.First; loop if Set_Node = 0 then - Result := Subset_Node = 0; - exit; + return Subset_Node = 0; end if; if Subset_Node = 0 then - Result := True; - exit; + return True; end if; if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then - Result := False; - exit; + return False; end if; if Is_Less (Of_Set.Nodes (Set_Node), @@ -497,23 +381,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Subset_Node := Tree_Operations.Next (Subset, Subset_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end Set_Subset; @@ -531,62 +398,29 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; - - Result : Boolean; - begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop if L_Node = 0 or else R_Node = 0 then - Result := False; - exit; + return False; end if; if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then L_Node := Tree_Operations.Next (Left, L_Node); - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then R_Node := Tree_Operations.Next (Right, R_Node); - else - Result := True; - exit; + return True; end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end Set_Overlap; @@ -598,12 +432,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is (Target : in out Set_Type; Source : Set_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Count_Type; Src : Count_Type; @@ -642,13 +470,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then Compare := -1; elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then @@ -656,21 +481,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -722,11 +532,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; @@ -735,12 +542,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -795,21 +596,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is R_Node := Tree_Operations.Next (Right, R_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end return; end Set_Symmetric_Difference; @@ -850,13 +636,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BS := BS + 1; - LS := LS + 1; - -- Note that there's no way to decide a priori whether the target has -- enough capacity for the union with source. We cannot simply -- compare the sum of the existing lengths to the capacity of the @@ -864,15 +645,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- the union. Iterate (Source); - - BS := BS - 1; - LS := LS - 1; - exception - when others => - BS := BS - 1; - LS := LS - 1; - - raise; end; end Set_Union; @@ -892,19 +664,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return Result : Set_Type (Left.Length + Right.Length) do declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - Assign (Target => Result, Source => Left); Insert_Right : declare @@ -934,21 +696,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is begin Iterate (Right); end Insert_Right; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end return; end Set_Union; diff --git a/gcc/ada/a-btgbso.ads b/gcc/ada/a-btgbso.ads index 06b58297eb0..0527a90c442 100644 --- a/gcc/ada/a-btgbso.ads +++ b/gcc/ada/a-btgbso.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,7 +37,7 @@ generic type Set_Type is new Tree_Operations.Tree_Types.Tree_Type with private; - use Tree_Operations.Tree_Types; + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; with procedure Assign (Target : in out Set_Type; Source : Set_Type); diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index c4e4945d702..2d8cbdaaeed 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +33,10 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -80,68 +84,34 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); LN : Node_Array renames Left.Nodes; RN : Node_Array renames Right.Nodes; LI : Count_Type; RI : Count_Type; - - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Length /= Right.Length then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - LI := Left.First; RI := Right.First; - Result := True; for J in 1 .. Left.Length loop if LN (LI).Element /= RN (RI).Element then - Result := False; - exit; + return False; end if; LI := LN (LI).Next; RI := RN (RI).Next; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + return True; end "="; -------------- @@ -230,24 +200,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is end Append; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List 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; - - ------------ -- Assign -- ------------ @@ -260,7 +212,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error -- ??? with "Target capacity is less than Source length"; end if; @@ -286,8 +238,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is if Container.Length = 0 then pragma Assert (Container.First = 0); pragma Assert (Container.Last = 0); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; @@ -296,10 +247,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); while Container.Length > 1 loop X := Container.First; @@ -332,30 +280,30 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - declare - N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; -------------- @@ -382,7 +330,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is C := Source.Length; elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -404,12 +352,13 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is X : Count_Type; begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -431,10 +380,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for Index in 1 .. Count loop pragma Assert (Container.Length >= 2); @@ -484,10 +430,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for J in 1 .. Count loop X := Container.First; @@ -523,10 +466,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for J in 1 .. Count loop X := Container.Last; @@ -547,15 +487,14 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Element"); + pragma Assert (Vet (Position), "bad cursor in Element"); - return Position.Container.Nodes (Position.Node).Element; - end if; + return Position.Container.Nodes (Position.Node).Element; end Element; -------------- @@ -565,27 +504,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List 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; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -606,7 +525,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Node := Container.First; else - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -618,39 +538,17 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Count_Type; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := 0; while Node /= 0 loop if Nodes (Node).Element = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Nodes (Node).Next; end loop; - B := B - 1; - L := L - 1; - - if Result = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Find; @@ -695,11 +593,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function First_Element (Container : List) return Element_Type is begin - if Container.First = 0 then + if Checks and then Container.First = 0 then raise Constraint_Error with "list is empty"; - else - return Container.Nodes (Container.First).Element; end if; + + return Container.Nodes (Container.First).Element; end First_Element; ---------- @@ -826,42 +724,24 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type; - - Result : Boolean; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; + Lock : With_Lock (Container.TC'Unrestricted_Access); + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type; + begin Node := Container.First; - Result := True; for J in 2 .. Container.Length loop if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then - Result := False; - exit; + return False; end if; Node := Nodes (Node).Next; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return True; end Is_Sorted; ----------- @@ -885,38 +765,30 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; - if Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length + then raise Constraint_Error with "new length exceeds maximum"; end if; - if Target.Length + Source.Length > Target.Capacity then + if Checks and then Target.Length + Source.Length > Target.Capacity + then raise Capacity_Error with "new length exceeds target capacity"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); LN : Node_Array renames Target.Nodes; RN : Node_Array renames Source.Nodes; @@ -924,12 +796,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is LI, LJ, RI, RJ : Count_Type; begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - LI := Target.First; RI := Source.First; while RI /= 0 loop @@ -955,22 +821,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is LI := LN (LI).Next; end if; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -1056,32 +906,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Front => 0, Back => 0); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - raise; end; pragma Assert (N (Container.First).Prev = 0); @@ -1090,6 +923,16 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1116,7 +959,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor designates wrong list"; end if; @@ -1129,14 +973,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Length > Container.Capacity - Count then + if Checks and then Container.Length > Container.Capacity - Count then raise Capacity_Error with "capacity exceeded"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); Allocate (Container, New_Item, New_Node); First_Node := New_Node; @@ -1258,32 +1099,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Count_Type := Container.First; begin - B := B + 1; - - begin - while Node /= 0 loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Container.Nodes (Node).Next; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= 0 loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Container.Nodes (Node).Next; + end loop; end Iterate; function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1300,7 +1129,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Container => Container'Unrestricted_Access, Node => 0) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1309,8 +1138,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1323,12 +1150,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong list"; end if; @@ -1349,7 +1176,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1394,11 +1221,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type is begin - if Container.Last = 0 then + if Checks and then Container.Last = 0 then raise Constraint_Error with "list is empty"; - else - return Container.Nodes (Container.Last).Element; end if; + + return Container.Nodes (Container.Last).Element; end Last_Element; ------------ @@ -1426,14 +1253,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Source.TC); -- Clear target, note that this checks busy bits of Target @@ -1533,12 +1357,14 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; - else - return Next (Position); end if; + + return Next (Position); end Next; ------------- @@ -1590,14 +1416,30 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; - else - return Previous (Position); end if; + + return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1607,7 +1449,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; @@ -1615,27 +1457,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Query_Element"); declare + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - + N : Node_Type renames C.Nodes (Position.Node); begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames C.Nodes (Position.Node); - begin - Process (N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Element); end; end Query_Element; @@ -1654,21 +1480,22 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Clear (Item); Count_Type'Base'Read (Stream, N); - if N < 0 then + if Checks and then N < 0 then raise Program_Error with "bad list length (corrupt stream)"; + end if; - elsif N = 0 then + if N = 0 then return; + end if; - elsif N > Item.Capacity then + if Checks and then N > Item.Capacity then raise Constraint_Error with "length exceeds capacity"; - - else - for Idx in 1 .. N loop - Allocate (Item, Stream, New_Node => X); - Insert_Internal (Item, Before => 0, New_Node => X); - end loop; end if; + + for Idx in 1 .. N loop + Allocate (Item, Stream, New_Node => X); + Insert_Internal (Item, Before => 0, New_Node => X); + end loop; end Read; procedure Read @@ -1704,30 +1531,30 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in function Reference"); + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- @@ -1740,22 +1567,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is New_Item : Element_Type) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; + TE_Check (Container.TC); - else - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - Container.Nodes (Position.Node).Element := New_Item; - end if; + Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; ---------------------- @@ -1817,10 +1642,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); Container.First := J; Container.Last := I; @@ -1862,7 +1684,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Node := Container.Last; else - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -1874,39 +1697,17 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Count_Type; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := 0; while Node /= 0 loop if Container.Nodes (Node).Element = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Container.Nodes (Node).Prev; end loop; - B := B - 1; - L := L - 1; - - if Result = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Reverse_Find; @@ -1918,26 +1719,14 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Count_Type := Container.Last; begin - B := B + 1; - - begin - while Node /= 0 loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Container.Nodes (Node).Prev; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= 0 loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Container.Nodes (Node).Prev; + end loop; end Reverse_Iterate; ------------ @@ -1951,7 +1740,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; end if; @@ -1961,24 +1750,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is if Target'Address = Source'Address or else Source.Length = 0 then return; + end if; - elsif Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Target.Length + Source.Length > Target.Capacity then + if Checks and then Target.Length + Source.Length > Target.Capacity then raise Capacity_Error with "new length exceeds target capacity"; + end if; - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Target.TC); + TC_Check (Source.TC); - else - Splice_Internal (Target, Before.Node, Source); - end if; + Splice_Internal (Target, Before.Node, Source); end Splice; procedure Splice @@ -1990,7 +1775,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unchecked_Access then + if Checks and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; end if; @@ -1998,11 +1783,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -2017,10 +1803,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); if Before.Node = 0 then pragma Assert (Position.Node /= Container.Last); @@ -2100,7 +1883,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is end if; if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; end if; @@ -2108,30 +1891,23 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); - if Target.Length >= Target.Capacity then + if Checks and then Target.Length >= Target.Capacity then raise Capacity_Error with "Target is full"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); Splice_Internal (Target => Target, @@ -2275,19 +2051,19 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = 0 then + if Checks and then I.Node = 0 then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = 0 then + if Checks and then J.Node = 0 then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unchecked_Access then + if Checks and then I.Container /= Container'Unchecked_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unchecked_Access then + if Checks and then J.Container /= Container'Unchecked_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2295,10 +2071,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; - end if; + TE_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (J), "bad J cursor in Swap"); @@ -2324,19 +2097,19 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = 0 then + if Checks and then I.Node = 0 then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = 0 then + if Checks and then J.Node = 0 then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2344,10 +2117,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (J), "bad J cursor in Swap_Links"); @@ -2388,11 +2158,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -2400,26 +2170,10 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Update_Element"); declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); + N : Node_Type renames Container.Nodes (Position.Node); begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - Process (N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Element); end; end Update_Element; diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads index 603cb35b7a0..ba063c1139e 100644 --- a/gcc/ada/a-cbdlli.ads +++ b/gcc/ada/a-cbdlli.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +private with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; @@ -248,6 +249,10 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + use Ada.Streams; use Ada.Finalization; @@ -265,8 +270,7 @@ private First : Count_Type := 0; Last : Count_Type := 0; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; procedure Read @@ -301,15 +305,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is new Controlled with record - Container : List_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -353,6 +350,25 @@ private for Reference_Type'Read use Read; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_List : constant List := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(null, 0); @@ -362,7 +378,8 @@ private record Container : List_Access; Node : Count_Type; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index 3772c779305..6d4bc55f370 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +33,8 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; @@ -41,6 +43,10 @@ package body Ada.Containers.Bounded_Hashed_Maps is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -120,24 +126,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is end "="; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Map 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; - - ------------ -- Assign -- ------------ @@ -168,7 +156,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Target capacity is less than Source length"; end if; @@ -204,12 +192,13 @@ package body Ada.Containers.Bounded_Hashed_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -219,15 +208,14 @@ package body Ada.Containers.Bounded_Hashed_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -240,25 +228,20 @@ package body Ada.Containers.Bounded_Hashed_Maps is Key_Ops.Find (Container'Unrestricted_Access.all, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; declare - Cur : Cursor := Find (Container, Key); - pragma Unmodified (Cur); - N : Node_Type renames Container.Nodes (Node); - B : Natural renames Cur.Container.Busy; - L : Natural renames Cur.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -291,7 +274,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -325,7 +308,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is begin Key_Ops.Delete_Key_Sans_Free (Container, Key, X); - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete key not in map"; end if; @@ -334,20 +317,18 @@ package body Ada.Containers.Bounded_Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; - if Container.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with cursors (map is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -366,7 +347,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is Key_Ops.Find (Container'Unrestricted_Access.all, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "no element available because key not in map"; end if; @@ -376,7 +357,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; @@ -404,12 +385,12 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; @@ -428,7 +409,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; @@ -445,7 +426,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; @@ -478,27 +459,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Map 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; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -536,6 +497,16 @@ package body Ada.Containers.Bounded_Hashed_Maps is return Object.Container.First; end First; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -571,10 +542,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); declare N : Node_Type renames Container.Nodes (Position.Node); @@ -648,7 +616,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- order to prevent divide-by-zero errors later, when we compute the -- buckets array index value for a key, given its hash value. - if Container.Buckets'Length = 0 then + if Checks and then Container.Buckets'Length = 0 then raise Capacity_Error with "No capacity for insertion"; end if; @@ -705,7 +673,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- order to prevent divide-by-zero errors later, when we compute the -- buckets array index value for a key, given its hash value. - if Container.Buckets'Length = 0 then + if Checks and then Container.Buckets'Length = 0 then raise Capacity_Error with "No capacity for insertion"; end if; @@ -726,7 +694,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert key already in map"; end if; @@ -763,35 +731,23 @@ package body Ada.Containers.Bounded_Hashed_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin return It : constant Iterator := (Limited_Controlled with Container => Container'Unrestricted_Access) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -801,7 +757,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; @@ -833,10 +789,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -885,7 +838,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -893,6 +846,21 @@ package body Ada.Containers.Bounded_Hashed_Maps is return Next (Position); end Next; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -903,7 +871,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is procedure (Key : Key_Type; Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -913,26 +881,9 @@ package body Ada.Containers.Bounded_Hashed_Maps is declare M : Map renames Position.Container.all; N : Node_Type renames M.Nodes (Position.Node); - B : Natural renames M.Busy; - L : Natural renames M.Lock; - + Lock : With_Lock (M.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - declare - - begin - Process (N.Key, N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Key, N.Element); end; end Query_Element; @@ -1017,12 +968,13 @@ package body Ada.Containers.Bounded_Hashed_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -1032,16 +984,14 @@ package body Ada.Containers.Bounded_Hashed_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1053,22 +1003,20 @@ package body Ada.Containers.Bounded_Hashed_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; declare N : Node_Type renames Container.Nodes (Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1085,19 +1033,15 @@ package body Ada.Containers.Bounded_Hashed_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace key not in map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); declare N : Node_Type renames Container.Nodes (Node); - begin N.Key := Key; N.Element := New_Item; @@ -1114,20 +1058,18 @@ package body Ada.Containers.Bounded_Hashed_Maps is New_Item : Element_Type) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Position.Container.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Position.Container.TC); pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -1143,7 +1085,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is Capacity : Count_Type) is begin - if Capacity > Container.Capacity then + if Checks and then Capacity > Container.Capacity then raise Capacity_Error with "requested capacity is too large"; end if; end Reserve_Capacity; @@ -1168,12 +1110,13 @@ package body Ada.Containers.Bounded_Hashed_Maps is Element : in out Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1182,24 +1125,9 @@ package body Ada.Containers.Bounded_Hashed_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (N.Key, N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Key, N.Element); end; end Update_Element; diff --git a/gcc/ada/a-cbhama.ads b/gcc/ada/a-cbhama.ads index a03bfe6ab07..1514fb84aed 100644 --- a/gcc/ada/a-cbhama.ads +++ b/gcc/ada/a-cbhama.ads @@ -338,7 +338,7 @@ private type Map (Capacity : Count_Type; Modulus : Hash_Type) is new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Streams; use Ada.Finalization; @@ -380,15 +380,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is new Controlled with record - Container : Map_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -432,6 +425,25 @@ private for Reference_Type'Read use Read; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Map : constant Map := (Hash_Table_Type with Capacity => 0, Modulus => 0); @@ -441,7 +453,8 @@ private Map_Iterator_Interfaces.Forward_Iterator with record Container : Map_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 5f87c295578..d75ac48bb21 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +33,8 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; @@ -41,6 +43,10 @@ package body Ada.Containers.Bounded_Hashed_Sets is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -141,24 +147,6 @@ package body Ada.Containers.Bounded_Hashed_Sets is end "="; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Set 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; - - ------------ -- Assign -- ------------ @@ -188,7 +176,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Target capacity is less than Source length"; end if; @@ -224,11 +212,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -237,16 +226,14 @@ package body Ada.Containers.Bounded_Hashed_Sets is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -277,7 +264,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is C := Source.Length; elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -314,7 +301,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -326,18 +313,16 @@ package body Ada.Containers.Bounded_Hashed_Sets is Position : in out Cursor) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -372,10 +357,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.TC); if Source.Length < Target.Length then Src_Node := HT_Ops.First (Source); @@ -460,7 +442,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -530,12 +512,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; @@ -570,7 +552,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Right : Element_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; @@ -589,7 +571,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; @@ -638,27 +620,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Set 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; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -693,6 +655,16 @@ package body Ada.Containers.Bounded_Hashed_Sets is return Object.Container.First; end First; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -727,10 +699,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Container.Nodes (Position.Node).Element := New_Item; end if; @@ -763,7 +732,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -816,7 +785,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is -- order to prevent divide-by-zero errors later, when we compute the -- buckets array index value for an element, given its hash value. - if Container.Buckets'Length = 0 then + if Checks and then Container.Buckets'Length = 0 then raise Capacity_Error with "No capacity for insertion"; end if; @@ -844,10 +813,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.TC); Tgt_Node := HT_Ops.First (Target); while Tgt_Node /= 0 loop @@ -982,30 +948,19 @@ package body Ada.Containers.Bounded_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Iterate (Container); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; begin - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); return It : constant Iterator := Iterator'(Limited_Controlled with Container => Container'Unrestricted_Access); @@ -1030,10 +985,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -1083,7 +1035,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1118,6 +1070,21 @@ package body Ada.Containers.Bounded_Hashed_Sets is return False; end Overlap; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1127,7 +1094,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -1136,24 +1103,9 @@ package body Ada.Containers.Bounded_Hashed_Sets is declare S : Set renames Position.Container.all; - B : Natural renames S.Busy; - L : Natural renames S.Lock; - + Lock : With_Lock (S.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (S.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (S.Nodes (Position.Node).Element); end; end Query_Element; @@ -1231,15 +1183,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is Node : constant Count_Type := Element_Keys.Find (Container, New_Item); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Container.Nodes (Node).Element := New_Item; end Replace; @@ -1250,12 +1199,13 @@ package body Ada.Containers.Bounded_Hashed_Sets is New_Item : Element_Type) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1274,7 +1224,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Capacity : Count_Type) is begin - if Capacity > Container.Capacity then + if Checks and then Capacity > Container.Capacity then raise Capacity_Error with "requested capacity is too large"; end if; end Reserve_Capacity; @@ -1342,10 +1292,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.TC); Iterate (Source); end Symmetric_Difference; @@ -1471,10 +1418,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.TC); -- ??? why is this code commented out ??? -- declare @@ -1623,23 +1567,6 @@ 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; @@ -1670,25 +1597,20 @@ package body Ada.Containers.Bounded_Hashed_Sets is Key_Keys.Find (Container'Unrestricted_Access.all, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; declare - Cur : Cursor := Find (Container, Key); - pragma Unmodified (Cur); - N : Node_Type renames Container.Nodes (Node); - B : Natural renames Cur.Container.Busy; - L : Natural renames Cur.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -1718,7 +1640,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -1737,7 +1659,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Key_Keys.Find (Container'Unrestricted_Access.all, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; @@ -1777,15 +1699,10 @@ package body Ada.Containers.Bounded_Hashed_Sets is 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; + Impl.Reference_Control_Type (Control).Finalize; - if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + if Checks and then + 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); @@ -1817,7 +1734,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -1847,11 +1764,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -1862,21 +1780,18 @@ package body Ada.Containers.Bounded_Hashed_Sets is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - begin return R : constant Reference_Type := (Element => N.Element'Unrestricted_Access, Control => (Controlled with + Container.TC'Unrestricted_Access, 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; + do + Lock (Container.TC); end return; end; end Reference_Preserving_Key; @@ -1888,27 +1803,24 @@ package body Ada.Containers.Bounded_Hashed_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; declare P : constant Cursor := Find (Container, Key); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - begin return R : constant Reference_Type := (Element => Container.Nodes (Node).Element'Unrestricted_Access, Control => (Controlled with + Container.TC'Unrestricted_Access, Container'Unrestricted_Access, Index => Key_Keys.Index (Container, Key), Old_Pos => P, Old_Hash => Hash (Key))) do - B := B + 1; - L := L + 1; + Lock (Container.TC); end return; end; end Reference_Preserving_Key; @@ -1925,7 +1837,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -1947,12 +1859,13 @@ package body Ada.Containers.Bounded_Hashed_Sets is N : Nodes_Type renames Container.Nodes; begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1977,34 +1890,14 @@ package body Ada.Containers.Bounded_Hashed_Sets is declare E : Element_Type renames N (Position.Node).Element; K : constant Key_Type := Key (E); - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - Eq : Boolean; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - -- Record bucket now, in case key is changed - Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); - - Process (E); - - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + -- Record bucket now, in case key is changed + Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); - L := L - 1; - B := B - 1; + Process (E); - if Eq then + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -2022,7 +1915,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is while N (Prev).Next /= Position.Node loop Prev := N (Prev).Next; - if Prev = 0 then + if Checks and then Prev = 0 then raise Program_Error with "Position cursor is bad (node not found)"; end if; diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads index c24fa8a1cf0..7f55d8d26e1 100644 --- a/gcc/ada/a-cbhase.ads +++ b/gcc/ada/a-cbhase.ads @@ -34,6 +34,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; +private with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; use Ada.Finalization; @@ -447,8 +448,10 @@ package Ada.Containers.Bounded_Hashed_Sets is type Set_Access is access all Set; for Set_Access'Storage_Size use 0; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Index : Hash_Type; @@ -456,9 +459,6 @@ package Ada.Containers.Bounded_Hashed_Sets is 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); @@ -496,7 +496,7 @@ private type Set (Capacity : Count_Type; Modulus : Hash_Type) is new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Streams; procedure Write @@ -537,15 +537,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is new Controlled with record - Container : Set_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -569,6 +562,25 @@ private for Constant_Reference_Type'Write use Write; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Set : constant Set := (Hash_Table_Type with Capacity => 0, Modulus => 0); @@ -578,7 +590,8 @@ private Set_Iterator_Interfaces.Forward_Iterator with record Container : Set_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index 2a075428071..24db4d453a7 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,12 +27,19 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Multiway_Trees is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + use Finalization; + -------------------- -- Root_Iterator -- -------------------- @@ -217,10 +224,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is function "=" (Left, Right : Tree) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Count /= Right.Count then return False; end if; @@ -236,24 +239,6 @@ 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 -- ------------------- @@ -343,7 +328,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is R, N : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; @@ -352,7 +337,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- search. For now we omit this check, pending a ruling from the ARG. -- ??? -- - -- if Is_Root (Position) then + -- if Checks and then Is_Root (Position) then -- raise Program_Error with "Position cursor designates root"; -- end if; @@ -383,11 +368,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is First, Last : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -395,15 +380,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Container.Count > Container.Capacity - Count then + if Checks and then Container.Count > Container.Capacity - Count then raise Capacity_Error with "requested count exceeds available storage"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then Initialize_Root (Container); @@ -443,7 +425,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Capacity < Source.Count then + if Checks and then Target.Capacity < Source.Count then raise Capacity_Error -- ??? with "Target capacity is less than Source count"; end if; @@ -521,15 +503,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is N : Count_Type'Base; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Child = No_Element then + if Checks and then Child = No_Element then raise Constraint_Error with "Child cursor has no element"; end if; - if Parent.Container /= Child.Container then + if Checks and then Parent.Container /= Child.Container then raise Program_Error with "Parent and Child in different containers"; end if; @@ -545,7 +527,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Result := Result + 1; N := Parent.Container.Nodes (N).Parent; - if N < 0 then + if Checks and then N < 0 then raise Program_Error with "Parent is not ancestor of Child"; end if; end loop; @@ -562,10 +544,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count : Count_Type; begin - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container_Count = 0 then return; @@ -596,17 +575,18 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; @@ -615,17 +595,14 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- "Position cursor in Constant_Reference is bad"); declare - C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Container.Elements (Position.Node)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -657,7 +634,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is C := Source.Count; elsif Capacity >= Source.Count then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -762,20 +739,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is Target_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in container"; end if; - if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; @@ -784,7 +763,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Is_Root (Source) then + if Checks and then Is_Root (Source) then raise Constraint_Error with "Source cursor designates root"; end if; @@ -1011,18 +990,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then pragma Assert (Is_Root (Parent)); @@ -1053,26 +1029,24 @@ package body Ada.Containers.Bounded_Multiway_Trees is X : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if not Is_Leaf (Position) then + if Checks and then not Is_Leaf (Position) then raise Constraint_Error with "Position cursor does not designate leaf"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -1095,22 +1069,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -1163,11 +1135,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node = Root_Node (Position.Container.all) then + if Checks and then Position.Node = Root_Node (Position.Container.all) + then raise Program_Error with "Position cursor designates root"; end if; @@ -1222,11 +1195,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is Right_Position : Cursor) return Boolean is begin - if Left_Position = No_Element then + if Checks and then Left_Position = No_Element then raise Constraint_Error with "Left cursor has no element"; end if; - if Right_Position = No_Element then + if Checks and then Right_Position = No_Element then raise Constraint_Error with "Right cursor has no element"; end if; @@ -1290,25 +1263,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is -------------- procedure Finalize (Object : in out Root_Iterator) is - B : Natural renames Object.Container.Busy; - begin - 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; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -1361,7 +1317,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Node : Count_Type'Base; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1426,13 +1382,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is Result : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Commented-out pending ruling by ARG. ??? - -- if Position.Container /= Container'Unrestricted_Access then + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then -- raise Program_Error with "Position cursor not in container"; -- end if; @@ -1474,6 +1432,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is return Find_In_Children (Container, Subtree, Item); end Find_In_Subtree; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements (Position.Node)'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1543,20 +1511,23 @@ package body Ada.Containers.Bounded_Multiway_Trees is Last : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1566,15 +1537,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Container.Count > Container.Capacity - Count then + if Checks and then Container.Count > Container.Capacity - Count then raise Capacity_Error with "requested count exceeds available storage"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then Initialize_Root (Container); @@ -1620,20 +1588,23 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- OK to reference, see below begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1643,15 +1614,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Container.Count > Container.Capacity - Count then + if Checks and then Container.Count > Container.Capacity - Count then raise Capacity_Error with "requested count exceeds available storage"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then Initialize_Root (Container); @@ -1832,26 +1800,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin if Container.Count = 0 then return; end if; - B := B + 1; - Iterate_Children (Container => Container, Subtree => Root_Node (Container), Process => Process); - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end Iterate; function Iterate (Container : Tree) @@ -1870,7 +1828,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1880,25 +1838,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is end if; declare - B : Natural renames Parent.Container.Busy; C : Count_Type; NN : Tree_Node_Array renames Parent.Container.Nodes; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - B := B + 1; - C := NN (Parent.Node).Children.First; while C > 0 loop Process (Cursor'(Parent.Container, Node => C)); C := NN (C).Next; end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end; end Iterate_Children; @@ -1931,14 +1880,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return Tree_Iterator_Interfaces.Reversible_Iterator'Class is C : constant Tree_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= C then + if Checks and then Parent.Container /= C then raise Program_Error with "Parent cursor not in container"; end if; @@ -1947,7 +1894,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Container => C, Subtree => Parent.Node) do - B := B + 1; + Busy (C.TC); end return; end Iterate_Children; @@ -1959,25 +1906,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + C : constant Tree_Access := Position.Container; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Implement Vet for multiway trees??? -- pragma Assert (Vet (Position), "bad subtree cursor"); - declare - B : Natural renames Position.Container.Busy; - begin - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => Position.Container, - Subtree => Position.Node) - do - B := B + 1; - end return; - end; + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => C, + Subtree => Position.Node) + do + Busy (C.TC); + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1985,7 +1929,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; @@ -1996,23 +1940,13 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare T : Tree renames Position.Container.all; - B : Natural renames T.Busy; - + Busy : With_Busy (T.TC'Unrestricted_Access); begin - B := B + 1; - if Is_Root (Position) then Iterate_Children (T, Position.Node, Process); else Iterate_Subtree (T, Position.Node, Process); end if; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end; end Iterate_Subtree; @@ -2047,7 +1981,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Node : Count_Type'Base; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -2084,10 +2018,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors of Source (tree is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -2106,7 +2037,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -2146,7 +2077,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -2254,11 +2185,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is First, Last : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -2266,15 +2197,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Container.Count > Container.Capacity - Count then + if Checks and then Container.Count > Container.Capacity - Count then raise Capacity_Error with "requested count exceeds available storage"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then Initialize_Root (Container); @@ -2315,7 +2243,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong tree"; end if; @@ -2357,6 +2285,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position := Previous_Sibling (Position); end Previous_Sibling; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -2366,33 +2308,19 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Element : Element_Type)) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Process (Element => T.Elements (Position.Node)); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; end; end Query_Element; @@ -2430,7 +2358,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is begin Count_Type'Read (Stream, Count); - if Count < 0 then + if Checks and then Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2480,7 +2408,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count_Type'Read (Stream, Total_Count); - if Total_Count < 0 then + if Checks and then Total_Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2488,7 +2416,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Total_Count > Container.Capacity then + if Checks and then Total_Count > Container.Capacity then raise Capacity_Error -- ??? with "node count in stream exceeds container capacity"; end if; @@ -2499,7 +2427,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Read_Children (Root_Node (Container)); - if Read_Count /= Total_Count then + if Checks and then Read_Count /= Total_Count then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2539,17 +2467,18 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; @@ -2558,19 +2487,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- "Position cursor in Constant_Reference is bad"); declare - C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Container.Elements (Position.Node)'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; - end Reference; -------------------- @@ -2623,22 +2549,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is New_Item : Element_Type) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); Container.Elements (Position.Node) := New_Item; end Replace_Element; @@ -2652,7 +2576,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -2663,24 +2587,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare NN : Tree_Node_Array renames Parent.Container.Nodes; - B : Natural renames Parent.Container.Busy; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); C : Count_Type; begin - B := B + 1; - C := NN (Parent.Node).Children.Last; while C > 0 loop Process (Cursor'(Parent.Container, Node => C)); C := NN (C).Prev; end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end; end Reverse_Iterate_Children; @@ -2716,32 +2631,36 @@ package body Ada.Containers.Bounded_Multiway_Trees is Source_Parent : Cursor) is begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Target'Unrestricted_Access then + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Target.Nodes (Before.Node).Parent /= Target_Parent.Node then + if Checks and then + Target.Nodes (Before.Node).Parent /= Target_Parent.Node + then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Source'Unrestricted_Access then + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in Source container"; end if; @@ -2756,12 +2675,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (Container => Target, + if Checks and then Is_Reachable (Container => Target, From => Target_Parent.Node, To => Source_Parent.Node) then @@ -2778,15 +2694,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); if Target.Count = 0 then Initialize_Root (Target); @@ -2807,32 +2716,39 @@ package body Ada.Containers.Bounded_Multiway_Trees is Source_Parent : Cursor) is begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Container.Nodes (Before.Node).Parent /= Target_Parent.Node then + if Checks and then + Container.Nodes (Before.Node).Parent /= Target_Parent.Node + then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in container"; end if; @@ -2843,12 +2759,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is pragma Assert (Container.Count > 0); - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (Container => Container, + if Checks and then Is_Reachable (Container => Container, From => Target_Parent.Node, To => Source_Parent.Node) then @@ -2944,7 +2857,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Count > Target.Capacity - Source_Count then + if Checks and then Target.Count > Target.Capacity - Source_Count then raise Capacity_Error -- ??? with "Source count exceeds available storage on Target"; end if; @@ -3002,33 +2915,34 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position : in out Cursor) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Target.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then Target.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor not in Source container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; @@ -3047,12 +2961,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is end if; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (Container => Target, + if Checks and then Is_Reachable (Container => Target, From => Parent.Node, To => Position.Node) then @@ -3067,15 +2978,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); if Target.Count = 0 then Initialize_Root (Target); @@ -3098,33 +3002,36 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position : Cursor) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Container.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then Container.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then -- Should this be PE instead? Need ARG confirmation. ??? @@ -3145,12 +3052,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is end if; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (Container => Container, + if Checks and then Is_Reachable (Container => Container, From => Parent.Node, To => Position.Node) then @@ -3181,7 +3085,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- is a bit of a misnomer here in the case of a bounded tree, because -- the elements must be copied from the source to the target. - if Target.Count > Target.Capacity - Source_Count then + if Checks and then Target.Count > Target.Capacity - Source_Count then raise Capacity_Error -- ??? with "Source count exceeds available storage on Target"; end if; @@ -3276,15 +3180,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is I, J : Cursor) is begin - if I = No_Element then + if Checks and then I = No_Element then raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor not in container"; end if; - if Is_Root (I) then + if Checks and then Is_Root (I) then raise Program_Error with "I cursor designates root"; end if; @@ -3292,22 +3196,19 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if J = No_Element then + if Checks and then J = No_Element then raise Constraint_Error with "J cursor has no element"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor not in container"; end if; - if Is_Root (J) then + if Checks and then Is_Root (J) then raise Program_Error with "J cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); declare EE : Element_Array renames Container.Elements; @@ -3329,37 +3230,24 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Process (Element => T.Elements (Position.Node)); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; end; end Update_Element; diff --git a/gcc/ada/a-cbmutr.ads b/gcc/ada/a-cbmutr.ads index 127b179d43c..93b5e27d89e 100644 --- a/gcc/ada/a-cbmutr.ads +++ b/gcc/ada/a-cbmutr.ads @@ -32,8 +32,9 @@ ------------------------------------------------------------------------------ with Ada.Iterator_Interfaces; + +private with Ada.Containers.Helpers; private with Ada.Streams; -private with Ada.Finalization; generic type Element_Type is private; @@ -270,8 +271,12 @@ package Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)); private + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + use Ada.Streams; - use Ada.Finalization; No_Node : constant Count_Type'Base := -1; -- Need to document all global declarations such as this ??? @@ -297,8 +302,7 @@ private Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); Elements : Element_Array (1 .. Capacity) := (others => <>); Free : Count_Type'Base := No_Node; - Busy : Integer := 0; - Lock : Integer := 0; + TC : aliased Tamper_Counts; Count : Count_Type := 0; end record; @@ -332,16 +336,8 @@ 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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -383,6 +379,25 @@ private Item : out Reference_Type); for Reference_Type'Read use Read; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Tree : constant Tree := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(others => <>); diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb index c45bf9a3b76..c9f113040a2 100644 --- a/gcc/ada/a-cborma.adb +++ b/gcc/ada/a-cborma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); @@ -41,6 +43,10 @@ package body Ada.Containers.Bounded_Ordered_Maps is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -108,11 +114,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; @@ -133,7 +139,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function "<" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; @@ -150,7 +156,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function "<" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; @@ -206,11 +212,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; @@ -231,7 +237,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function ">" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; @@ -247,7 +253,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; @@ -263,24 +269,6 @@ package body Ada.Containers.Bounded_Ordered_Maps is end ">"; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Map 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; - - ------------ -- Assign -- ------------ @@ -358,7 +346,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Target capacity is less than Source length"; end if; @@ -409,12 +397,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -424,16 +413,14 @@ package body Ada.Containers.Bounded_Ordered_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -445,25 +432,20 @@ package body Ada.Containers.Bounded_Ordered_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; declare - Cur : Cursor := Find (Container, Key); - pragma Unmodified (Cur); - N : Node_Type renames Container.Nodes (Node); - B : Natural renames Cur.Container.Busy; - L : Natural renames Cur.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -491,7 +473,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -506,12 +488,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; @@ -529,7 +512,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is X : constant Count_Type := Key_Ops.Find (Container, Key); begin - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "key not in map"; end if; @@ -571,7 +554,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; @@ -585,11 +568,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Element (Container : Map; Key : Key_Type) return Element_Type is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; - else - return Container.Nodes (Node).Element; end if; + + return Container.Nodes (Node).Element; end Element; --------------------- @@ -628,27 +611,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Map 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; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -707,11 +670,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function First_Element (Container : Map) return Element_Type is begin - if Container.First = 0 then + if Checks and then Container.First = 0 then raise Constraint_Error with "map is empty"; - else - return Container.Nodes (Container.First).Element; end if; + + return Container.Nodes (Container.First).Element; end First_Element; --------------- @@ -720,11 +683,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function First_Key (Container : Map) return Key_Type is begin - if Container.First = 0 then + if Checks and then Container.First = 0 then raise Constraint_Error with "map is empty"; - else - return Container.Nodes (Container.First).Key; end if; + + return Container.Nodes (Container.First).Key; end First_Key; ----------- @@ -741,6 +704,16 @@ package body Ada.Containers.Bounded_Ordered_Maps is end if; end Floor; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -766,10 +739,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); declare N : Node_Type renames Container.Nodes (Position.Node); @@ -852,7 +822,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "key already in map"; end if; end Insert; @@ -979,29 +949,17 @@ package body Ada.Containers.Bounded_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1018,7 +976,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is Container => Container'Unrestricted_Access, Node => 0) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1027,8 +985,6 @@ package body Ada.Containers.Bounded_Ordered_Maps is Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- Iterator was defined to behave the same as for a complete iterator, -- and iterate over the entire sequence of items. However, those @@ -1040,12 +996,12 @@ package body Ada.Containers.Bounded_Ordered_Maps is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong map"; end if; @@ -1067,7 +1023,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1077,7 +1033,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; @@ -1129,11 +1085,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Last_Element (Container : Map) return Element_Type is begin - if Container.Last = 0 then + if Checks and then Container.Last = 0 then raise Constraint_Error with "map is empty"; - else - return Container.Nodes (Container.Last).Element; end if; + + return Container.Nodes (Container.Last).Element; end Last_Element; -------------- @@ -1142,11 +1098,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Last_Key (Container : Map) return Key_Type is begin - if Container.Last = 0 then + if Checks and then Container.Last = 0 then raise Constraint_Error with "map is empty"; - else - return Container.Nodes (Container.Last).Key; end if; + + return Container.Nodes (Container.Last).Key; end Last_Key; ---------- @@ -1177,10 +1133,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -1228,7 +1181,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -1287,7 +1240,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong map"; end if; @@ -1295,6 +1248,21 @@ package body Ada.Containers.Bounded_Ordered_Maps is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1305,7 +1273,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -1316,25 +1284,9 @@ package body Ada.Containers.Bounded_Ordered_Maps is declare M : Map renames Position.Container.all; N : Node_Type renames M.Nodes (Position.Node); - - B : Natural renames M.Busy; - L : Natural renames M.Lock; - + Lock : With_Lock (M.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (N.Key, N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Key, N.Element); end; end Query_Element; @@ -1404,12 +1356,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -1419,15 +1372,14 @@ package body Ada.Containers.Bounded_Ordered_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1439,21 +1391,20 @@ package body Ada.Containers.Bounded_Ordered_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; declare N : Node_Type renames Container.Nodes (Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1470,14 +1421,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); declare N : Node_Type renames Container.Nodes (Node); @@ -1498,20 +1446,18 @@ package body Ada.Containers.Bounded_Ordered_Maps is New_Item : Element_Type) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); pragma Assert (Vet (Container, Position.Node), "Position cursor of Replace_Element is bad"); @@ -1542,22 +1488,12 @@ package body Ada.Containers.Bounded_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (Container); end Reverse_Iterate; ----------- @@ -1619,12 +1555,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is Element : in out Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1634,25 +1571,9 @@ package body Ada.Containers.Bounded_Ordered_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (N.Key, N.Element); - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Key, N.Element); end; end Update_Element; diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads index df1a2a2076f..2b68bbffb47 100644 --- a/gcc/ada/a-cborma.ads +++ b/gcc/ada/a-cborma.ads @@ -248,7 +248,7 @@ private new Tree_Types.Tree_Type (Capacity) with null record; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Streams; procedure Write @@ -283,15 +283,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is new Controlled with record - Container : Map_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -335,6 +328,25 @@ private for Reference_Type'Write use Write; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0); No_Element : constant Cursor := Cursor'(null, 0); @@ -344,7 +356,8 @@ private record Container : Map_Access; Node : Count_Type; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index af894ee11fb..84c71492e09 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); @@ -44,6 +46,10 @@ package body Ada.Containers.Bounded_Ordered_Sets is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ------------------------------ -- Access to Fields of Node -- ------------------------------ @@ -141,11 +147,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -165,7 +171,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor equals No_Element"; end if; @@ -177,7 +183,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -219,11 +225,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -245,7 +251,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -257,7 +263,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor equals No_Element"; end if; @@ -268,24 +274,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is end ">"; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Set 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; - - ------------ -- Assign -- ------------ @@ -361,7 +349,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Target capacity is less than Source length"; end if; @@ -409,11 +397,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -424,15 +413,14 @@ package body Ada.Containers.Bounded_Ordered_Sets is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -461,7 +449,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is C := Source.Length; elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -476,18 +464,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (Container, Position.Node), "bad cursor in Delete"); @@ -504,7 +490,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is begin Tree_Operations.Delete_Node_Sans_Free (Container, X); - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -553,7 +539,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -620,27 +606,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Set 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; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -693,7 +659,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function First_Element (Container : Set) return Element_Type is begin - if Container.First = 0 then + if Checks and then Container.First = 0 then raise Constraint_Error with "set is empty"; end if; @@ -742,23 +708,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); - ------------ - -- 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; - ------------- -- Ceiling -- ------------- @@ -782,25 +731,20 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; declare - Cur : Cursor := Find (Container, Key); - pragma Unmodified (Cur); - N : Node_Type renames Container.Nodes (Node); - B : Natural renames Cur.Container.Busy; - L : Natural renames Cur.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -822,7 +766,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is X : constant Count_Type := Key_Keys.Find (Container, Key); begin - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -838,7 +782,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; @@ -874,15 +818,10 @@ package body Ada.Containers.Bounded_Ordered_Sets is 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 not (Key (Control.Pos) = Control.Old_Key.all) then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then Delete (Control.Container.all, Key (Control.Pos)); raise Program_Error; end if; @@ -943,7 +882,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -975,11 +914,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -990,19 +930,17 @@ package body Ada.Containers.Bounded_Ordered_Sets is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; begin return R : constant Reference_Type := (Element => N.Element'Access, Control => (Controlled with + Container.TC'Unrestricted_Access, Container => Container'Access, Pos => Position, Old_Key => new Key_Type'(Key (Position)))) do - B := B + 1; - L := L + 1; + Lock (Container.TC); end return; end; end Reference_Preserving_Key; @@ -1014,25 +952,23 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; declare N : Node_Type renames Container.Nodes (Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; begin return R : constant Reference_Type := (Element => N.Element'Access, Control => (Controlled with + Container.TC'Unrestricted_Access, Container => Container'Access, Pos => Find (Container, Key), Old_Key => new Key_Type'(Key))) do - B := B + 1; - L := L + 1; + Lock (Container.TC); end return; end; end Reference_Preserving_Key; @@ -1049,7 +985,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -1067,12 +1003,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1087,30 +1024,10 @@ package body Ada.Containers.Bounded_Ordered_Sets is N : Node_Type renames Container.Nodes (Position.Node); E : Element_Type renames N.Element; K : constant Key_Type := Key (E); - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - Eq : Boolean; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Eq then + Process (E); + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -1134,6 +1051,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Write; end Generic_Keys; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1155,10 +1082,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Container.Nodes (Position.Node).Element := New_Item; end if; @@ -1196,7 +1120,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -1250,10 +1174,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- Start of processing for Insert_Sans_Hint begin - if Container.Busy > 0 then - raise Program_Error with - "attemot to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.TC); Conditional_Insert_Sans_Hint (Container, @@ -1411,29 +1332,17 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Process_Node; S : Set renames Container'Unrestricted_Access.all; - B : Natural renames S.Busy; + Busy : With_Busy (S.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (S); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (S); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1450,15 +1359,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is Container => Container'Unrestricted_Access, Node => 0) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; function Iterate (Container : Set; Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1471,12 +1378,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong set"; end if; @@ -1498,7 +1405,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1540,7 +1447,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function Last_Element (Container : Set) return Element_Type is begin - if Container.Last = 0 then + if Checks and then Container.Last = 0 then raise Constraint_Error with "set is empty"; end if; @@ -1575,10 +1482,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -1621,7 +1525,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1678,7 +1582,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong set"; end if; @@ -1686,6 +1590,21 @@ package body Ada.Containers.Bounded_Ordered_Sets is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1695,7 +1614,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -1704,24 +1623,9 @@ package body Ada.Containers.Bounded_Ordered_Sets is declare S : Set renames Position.Container.all; - B : Natural renames S.Busy; - L : Natural renames S.Lock; - + Lock : With_Lock (S.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (S.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (S.Nodes (Position.Node).Element); end; end Query_Element; @@ -1781,15 +1685,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Element_Keys.Find (Container, New_Item); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Container.Nodes (Node).Element := New_Item; end Replace; @@ -1841,12 +1742,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is Inserted : Boolean; Compare : Boolean; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - -- Start of processing for Replace_Element begin @@ -1864,22 +1759,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- Determine whether Item is equivalent to element on the specified -- node. + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := (if Item < Node.Element then False elsif Node.Element < Item then False else True); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; end; if Compare then @@ -1887,10 +1772,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- Item is equivalent to the node's element, so we will not have to -- move the node. - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Node.Element := Item; return; @@ -1908,25 +1790,15 @@ package body Ada.Containers.Bounded_Ordered_Sets is Hint := Element_Keys.Ceiling (Container, Item); if Hint /= 0 then -- Item <= Nodes (Hint).Element + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Item < Nodes (Hint).Element; - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; end; -- Item is equivalent to Nodes (Hint).Element - if not Compare then + if Checks and then not Compare then -- Ceiling returns an element that is equivalent or greater than -- Item. If Item is "not less than" the element, then by @@ -1958,10 +1830,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- because it would only be placed in the exact same position. if Hint = Index then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Node.Element := Item; return; @@ -1993,12 +1862,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is New_Item : Element_Type) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -2033,22 +1903,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Process_Node; S : Set renames Container'Unrestricted_Access.all; - B : Natural renames S.Busy; + Busy : With_Busy (S.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (S); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (S); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads index 9b474a66353..a12a7988a93 100644 --- a/gcc/ada/a-cborse.ads +++ b/gcc/ada/a-cborse.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +private with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Streams; private with Ada.Finalization; @@ -284,17 +285,16 @@ package Ada.Containers.Bounded_Ordered_Sets is use Ada.Streams; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Pos : Cursor; Old_Key : Key_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); @@ -335,7 +335,7 @@ private type Set (Capacity : Count_Type) is new Tree_Types.Tree_Type (Capacity) with null record; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -377,15 +377,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is new Controlled with record - Container : Set_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -409,6 +402,25 @@ private for Constant_Reference_Type'Write use Write; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Set : constant Set := Set'(Tree_Type with Capacity => 0); No_Element : constant Cursor := Cursor'(null, 0); @@ -418,7 +430,8 @@ private record Container : Set_Access; Node : Count_Type; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index e003cfc7c3d..6cd1ae7e400 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -35,6 +35,10 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -69,64 +73,32 @@ package body Ada.Containers.Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L : Node_Access; R : Node_Access; - Result : Boolean; begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Length /= Right.Length then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L := Left.First; R := Right.First; - Result := True; for J in 1 .. Left.Length loop if L.Element /= R.Element then - Result := False; - exit; + return False; end if; L := L.Next; R := R.Next; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + return True; end "="; ------------ @@ -140,8 +112,7 @@ package body Ada.Containers.Doubly_Linked_Lists is if Src = null then pragma Assert (Container.Last = null); pragma Assert (Container.Length = 0); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; @@ -152,8 +123,7 @@ package body Ada.Containers.Doubly_Linked_Lists is Container.First := null; Container.Last := null; Container.Length := 0; - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); Container.First := new Node_Type'(Src.Element, null, null); Container.Last := Container.First; @@ -171,20 +141,6 @@ package body Ada.Containers.Doubly_Linked_Lists is end loop; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List 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; - ------------ -- Append -- ------------ @@ -230,18 +186,14 @@ package body Ada.Containers.Doubly_Linked_Lists is if Container.Length = 0 then pragma Assert (Container.First = null); pragma Assert (Container.Last = null); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); while Container.Length > 1 loop X := Container.First; @@ -276,11 +228,12 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -288,16 +241,14 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -337,12 +288,13 @@ package body Ada.Containers.Doubly_Linked_Lists is X : Node_Access; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -360,10 +312,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for Index in 1 .. Count loop X := Position.Node; @@ -412,10 +361,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for J in 1 .. Count loop X := Container.First; @@ -450,10 +396,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for J in 1 .. Count loop X := Container.Last; @@ -474,14 +417,14 @@ package body Ada.Containers.Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; - else - pragma Assert (Vet (Position), "bad cursor in Element"); - - return Position.Node.Element; end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + + return Position.Node.Element; end Element; -------------- @@ -491,27 +434,7 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List 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; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -531,57 +454,30 @@ package body Ada.Containers.Doubly_Linked_Lists is Node := Container.First; else - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - else - pragma Assert (Vet (Position), "bad cursor in Find"); end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); end if; -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Node_Access; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - pragma Warnings (Off); - -- Deal with junk infinite loop warning from below loop - - Result := null; while Node /= null loop if Node.Element = Item then - Result := Node; - exit; - else - Node := Node.Next; + return Cursor'(Container'Unrestricted_Access, Node); end if; - end loop; - pragma Warnings (On); - -- End of section dealing with junk infinite loop warning - - B := B - 1; - L := L - 1; - - if Result = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; + Node := Node.Next; + end loop; - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Find; @@ -626,11 +522,11 @@ package body Ada.Containers.Doubly_Linked_Lists is function First_Element (Container : List) return Element_Type is begin - if Container.First = null then + if Checks and then Container.First = null then raise Constraint_Error with "list is empty"; - else - return Container.First.Element; end if; + + return Container.First.Element; end First_Element; ---------- @@ -673,40 +569,23 @@ package body Ada.Containers.Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Node : Node_Access; - Result : Boolean; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; + Lock : With_Lock (Container.TC'Unrestricted_Access); + Node : Node_Access; + begin Node := Container.First; - Result := True; for Idx in 2 .. Container.Length loop if Node.Next.Element < Node.Element then - Result := False; - exit; + return False; end if; Node := Node.Next; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return True; end Is_Sorted; ----------- @@ -730,44 +609,29 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; - if Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length + then raise Constraint_Error with "new length exceeds maximum"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); LI, RI, RJ : Node_Access; begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - LI := Target.First; RI := Source.First; while RI /= null loop @@ -791,22 +655,6 @@ package body Ada.Containers.Doubly_Linked_Lists is LI := LI.Next; end if; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -889,32 +737,15 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Front => null, Back => null); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - raise; end; pragma Assert (Container.First.Prev = null); @@ -959,37 +790,36 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor designates wrong list"; - else - pragma Assert (Vet (Before), "bad cursor in Insert"); end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then Position := Before; return; + end if; - elsif Container.Length > Count_Type'Last - Count then + if Checks and then Container.Length > Count_Type'Last - Count then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + TC_Check (Container.TC); - else - New_Node := new Node_Type'(New_Item, null, null); - First_Node := New_Node; - Insert_Internal (Container, Before.Node, New_Node); + New_Node := new Node_Type'(New_Item, null, null); + First_Node := New_Node; + Insert_Internal (Container, Before.Node, New_Node); - for J in 2 .. Count loop - New_Node := new Node_Type'(New_Item, null, null); - Insert_Internal (Container, Before.Node, New_Node); - end loop; + for J in 2 .. Count loop + New_Node := new Node_Type'(New_Item, null, null); + Insert_Internal (Container, Before.Node, New_Node); + end loop; - Position := Cursor'(Container'Unchecked_Access, First_Node); - end if; + Position := Cursor'(Container'Unchecked_Access, First_Node); end Insert; procedure Insert @@ -1015,12 +845,13 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor designates wrong list"; - else - pragma Assert (Vet (Before), "bad cursor in Insert"); end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then @@ -1028,25 +859,22 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Length > Count_Type'Last - Count then + if Checks and then Container.Length > Count_Type'Last - Count then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + TC_Check (Container.TC); - else - New_Node := new Node_Type; - First_Node := New_Node; - Insert_Internal (Container, Before.Node, New_Node); + New_Node := new Node_Type; + First_Node := New_Node; + Insert_Internal (Container, Before.Node, New_Node); - for J in 2 .. Count loop - New_Node := new Node_Type; - Insert_Internal (Container, Before.Node, New_Node); - end loop; + for J in 2 .. Count loop + New_Node := new Node_Type; + Insert_Internal (Container, Before.Node, New_Node); + end loop; - Position := Cursor'(Container'Unchecked_Access, First_Node); - end if; + Position := Cursor'(Container'Unchecked_Access, First_Node); end Insert; --------------------- @@ -1114,31 +942,19 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Node_Access := Container.First; begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Next; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Next; + end loop; end Iterate; function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1155,15 +971,13 @@ package body Ada.Containers.Doubly_Linked_Lists is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; function Iterate (Container : List; Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1176,34 +990,34 @@ package body Ada.Containers.Doubly_Linked_Lists is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; + end if; - elsif Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong list"; - - else - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the - -- First and Last selector functions of the iterator object. When - -- the Node component is non-null (as is the case here), it means - -- that this is a partial iteration, over a subset of the complete - -- sequence of items. The iterator object was constructed with - -- a start expression, indicating the position from which the - -- iteration begins. Note that the start position has the same value - -- irrespective of whether this is a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - B := B + 1; - end return; end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of items. + -- The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; end Iterate; ---------- @@ -1247,11 +1061,11 @@ package body Ada.Containers.Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type is begin - if Container.Last = null then + if Checks and then Container.Last = null then raise Constraint_Error with "list is empty"; - else - return Container.Last.Element; end if; + + return Container.Last.Element; end Last_Element; ------------ @@ -1274,23 +1088,20 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Target'Address = Source'Address then return; + end if; - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Source.TC); - else - Clear (Target); + Clear (Target); - Target.First := Source.First; - Source.First := null; + Target.First := Source.First; + Source.First := null; - Target.Last := Source.Last; - Source.Last := null; + Target.Last := Source.Last; + Source.Last := null; - Target.Length := Source.Length; - Source.Length := 0; - end if; + Target.Length := Source.Length; + Source.Length := 0; end Move; ---------- @@ -1329,12 +1140,14 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; - else - return Next (Position); end if; + + return Next (Position); end Next; ------------- @@ -1386,12 +1199,14 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; - else - return Previous (Position); end if; + + return Previous (Position); end Previous; ---------------------- @@ -1401,15 +1216,10 @@ package body Ada.Containers.Doubly_Linked_Lists is function Pseudo_Reference (Container : aliased List'Class) return Reference_Control_Type is - C : constant List_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -1422,7 +1232,7 @@ package body Ada.Containers.Doubly_Linked_Lists is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; @@ -1430,25 +1240,9 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Query_Element"); declare - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element); end; end Query_Element; @@ -1537,30 +1331,28 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in function Reference"); + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- @@ -1573,22 +1365,20 @@ package body Ada.Containers.Doubly_Linked_Lists is New_Item : Element_Type) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; + TE_Check (Container.TC); - else - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - Position.Node.Element := New_Item; - end if; + Position.Node.Element := New_Item; end Replace_Element; ---------------------- @@ -1649,10 +1439,7 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); Container.First := J; Container.Last := I; @@ -1694,51 +1481,30 @@ package body Ada.Containers.Doubly_Linked_Lists is Node := Container.Last; else - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - else - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Node_Access; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := null; while Node /= null loop if Node.Element = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; end loop; - B := B - 1; - L := L - 1; - - if Result = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Reverse_Find; @@ -1750,26 +1516,14 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Node_Access := Container.Last; begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Prev; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Prev; + end loop; end Reverse_Iterate; ------------ @@ -1783,31 +1537,26 @@ package body Ada.Containers.Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; - else - pragma Assert (Vet (Before), "bad cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad cursor in Splice"); end if; if Target'Address = Source'Address or else Source.Length = 0 then return; + end if; - elsif Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Target.TC); + TC_Check (Source.TC); - else - Splice_Internal (Target, Before.Node, Source); - end if; + Splice_Internal (Target, Before.Node, Source); end Splice; procedure Splice @@ -1817,19 +1566,20 @@ package body Ada.Containers.Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Container'Unchecked_Access then + if Checks and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; - else - pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -1844,10 +1594,7 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); if Before.Node = null then pragma Assert (Position.Node /= Container.Last); @@ -1925,40 +1672,34 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; - else - pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Target.Length = Count_Type'Last then - raise Constraint_Error with "Target is full"; + pragma Assert (Vet (Position), "bad Position cursor in Splice"); - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; + if Checks and then Target.Length = Count_Type'Last then + raise Constraint_Error with "Target is full"; + end if; - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Target.TC); + TC_Check (Source.TC); - else - Splice_Internal (Target, Before.Node, Source, Position.Node); - Position.Container := Target'Unchecked_Access; - end if; - end if; + Splice_Internal (Target, Before.Node, Source, Position.Node); + Position.Container := Target'Unchecked_Access; end Splice; --------------------- @@ -2114,19 +1855,19 @@ package body Ada.Containers.Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null then + if Checks and then I.Node = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = null then + if Checks and then J.Node = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unchecked_Access then + if Checks and then I.Container /= Container'Unchecked_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unchecked_Access then + if Checks and then J.Container /= Container'Unchecked_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2134,10 +1875,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; - end if; + TE_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (J), "bad J cursor in Swap"); @@ -2163,19 +1901,19 @@ package body Ada.Containers.Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null then + if Checks and then I.Node = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = null then + if Checks and then J.Node = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2183,10 +1921,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (J), "bad J cursor in Swap_Links"); @@ -2227,37 +1962,22 @@ package body Ada.Containers.Doubly_Linked_Lists is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + pragma Assert (Vet (Position), "bad cursor in Update_Element"); - L := L - 1; - B := B - 1; - end; - end if; + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Process (Position.Node.Element); + end; end Update_Element; --------- diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 35aaf9f6099..45abeb1559f 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +private with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -248,6 +249,10 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Node_Type; type Node_Access is access Node_Type; @@ -263,11 +268,10 @@ private type List is new Controlled with record - First : Node_Access; - Last : Node_Access; + First : Node_Access := null; + Last : Node_Access := null; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; overriding procedure Adjust (Container : in out List); @@ -307,16 +311,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : List_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -374,13 +370,14 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_List : constant List := (Controlled with null, null, 0, 0, 0); + Empty_List : constant List := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -389,7 +386,8 @@ private record Container : List_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-chtgbk.adb b/gcc/ada/a-chtgbk.adb index 941da83a493..43d0c1aece2 100644 --- a/gcc/ada/a-chtgbk.adb +++ b/gcc/ada/a-chtgbk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +29,10 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Checked_Equivalent_Keys -- ----------------------------- @@ -38,28 +42,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is Key : Key_Type; Node : Count_Type) return Boolean is - Result : Boolean; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Equivalent_Keys (Key, HT.Nodes (Node)); - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Equivalent_Keys (Key, HT.Nodes (Node)); end Checked_Equivalent_Keys; ------------------- @@ -70,28 +55,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is (HT : aliased in out Hash_Table_Type'Class; Key : Key_Type) return Hash_Type is - Result : Hash_Type; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; end Checked_Index; -------------------------- @@ -115,10 +81,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Indx := Checked_Index (HT, Key); X := HT.Buckets (Indx); @@ -128,10 +91,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is end if; if Checked_Equivalent_Keys (HT, Key, X) then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); HT.Buckets (Indx) := Next (HT.Nodes (X)); HT.Length := HT.Length - 1; return; @@ -146,10 +106,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is end if; if Checked_Equivalent_Keys (HT, Key, X) then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X))); HT.Length := HT.Length - 1; return; @@ -204,16 +161,13 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Indx := Checked_Index (HT, Key); Node := HT.Buckets (Indx); if Node = 0 then - if HT.Length = HT.Capacity then + if Checks and then HT.Length = HT.Capacity then raise Capacity_Error with "no more capacity for insertion"; end if; @@ -239,7 +193,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is exit when Node = 0; end loop; - if HT.Length = HT.Capacity then + if Checks and then HT.Length = HT.Capacity then raise Capacity_Error with "no more capacity for insertion"; end if; @@ -285,24 +239,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- the computation of New_Index until after the tampering check. ??? declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; -- Replace_Element is allowed to change a node's key to Key @@ -311,10 +250,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- hash table as this one, a key is mapped to exactly one node.) if Checked_Equivalent_Keys (HT, Key, Node) then - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (container is locked)"; - end if; + TE_Check (HT.TC); -- The new Key value is mapped to this same Node, so Node -- stays in the same bucket. @@ -330,7 +266,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is N := New_Bucket; while N /= 0 loop - if Checked_Equivalent_Keys (HT, Key, N) then + if Checks and then Checked_Equivalent_Keys (HT, Key, N) then pragma Assert (N /= Node); raise Program_Error with "attempt to replace existing element"; @@ -350,10 +286,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- The node is already in the bucket implied by Key. In this case -- we merely change its value without moving it. - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (container is locked)"; - end if; + TE_Check (HT.TC); Assign (NN (Node), Key); return; @@ -361,10 +294,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- The node is a bucket different from the bucket implied by Key - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); -- Do the assignment first, before moving the node, so that if Assign -- propagates an exception, then the hash table will not have been diff --git a/gcc/ada/a-chtgbk.ads b/gcc/ada/a-chtgbk.ads index d6d207780f6..037a87ec499 100644 --- a/gcc/ada/a-chtgbk.ads +++ b/gcc/ada/a-chtgbk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +34,7 @@ generic with package HT_Types is new Generic_Bounded_Hash_Table_Types (<>); - use HT_Types; + use HT_Types, HT_Types.Implementation; with function Next (Node : Node_Type) return Count_Type; diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index d114bc8bb04..f4f7c1c237e 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,10 @@ with System; use type System.Address; package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ------------------- -- Checked_Index -- ------------------- @@ -39,28 +43,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is (Hash_Table : aliased in out Hash_Table_Type'Class; Node : Count_Type) return Hash_Type is - Result : Hash_Type; - - B : Natural renames Hash_Table.Busy; - L : Natural renames Hash_Table.Lock; - + Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Index (Hash_Table, Hash_Table.Nodes (Node)); - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Index (Hash_Table, Hash_Table.Nodes (Node)); end Checked_Index; ----------- @@ -69,10 +54,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is procedure Clear (HT : in out Hash_Table_Type'Class) is begin - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); HT.Length := 0; -- HT.Busy := 0; @@ -96,7 +78,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is begin Prev := HT.Buckets (Indx); - if Prev = 0 then + if Checks and then Prev = 0 then raise Program_Error with "attempt to delete node from empty hash bucket"; end if; @@ -107,7 +89,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is return; end if; - if HT.Length = 1 then + if Checks and then HT.Length = 1 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -115,7 +97,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is loop Curr := Next (HT.Nodes (Prev)); - if Curr = 0 then + if Checks and then Curr = 0 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -139,7 +121,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is Curr : Count_Type; begin - if HT.Length = 0 then + if Checks and then HT.Length = 0 then raise Program_Error with "attempt to delete node from empty hashed container"; end if; @@ -147,7 +129,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is Indx := Checked_Index (HT, X); Prev := HT.Buckets (Indx); - if Prev = 0 then + if Checks and then Prev = 0 then raise Program_Error with "attempt to delete node from empty hash bucket"; end if; @@ -158,7 +140,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is return; end if; - if HT.Length = 1 then + if Checks and then HT.Length = 1 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -166,7 +148,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is loop Curr := Next (HT.Nodes (Prev)); - if Curr = 0 then + if Checks and then Curr = 0 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -363,13 +345,11 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is function Generic_Equal (L, R : Hash_Table_Type'Class) return Boolean is - BL : Natural renames L'Unrestricted_Access.Busy; - LL : Natural renames L'Unrestricted_Access.Lock; - - BR : Natural renames R'Unrestricted_Access.Busy; - LR : Natural renames R'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Result : Boolean; + Lock_L : With_Lock (L.TC'Unrestricted_Access); + Lock_R : With_Lock (R.TC'Unrestricted_Access); L_Index : Hash_Type; L_Node : Count_Type; @@ -398,23 +378,13 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is L_Index := L_Index + 1; end loop; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - -- For each node of hash table L, search for an equivalent node in hash -- table R. N := L.Length; loop if not Find (HT => R, Key => L.Nodes (L_Node)) then - Result := False; - exit; + return False; end if; N := N - 1; @@ -426,8 +396,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- We have exhausted the nodes in this bucket if N = 0 then - Result := True; - exit; + return True; end if; -- Find the next bucket @@ -439,24 +408,6 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is end loop; end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end Generic_Equal; ----------------------- @@ -495,7 +446,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is Count_Type'Base'Read (Stream, N); - if N < 0 then + if Checks and then N < 0 then raise Program_Error with "stream appears to be corrupt"; end if; @@ -503,7 +454,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is return; end if; - if N > HT.Capacity then + if Checks and then N > HT.Capacity then raise Capacity_Error with "too many elements in stream"; end if; diff --git a/gcc/ada/a-chtgbo.ads b/gcc/ada/a-chtgbo.ads index 5019154205d..892bdaaf1df 100644 --- a/gcc/ada/a-chtgbo.ads +++ b/gcc/ada/a-chtgbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,7 +36,7 @@ generic with package HT_Types is new Generic_Bounded_Hash_Table_Types (<>); - use HT_Types; + use HT_Types, HT_Types.Implementation; with function Hash_Node (Node : Node_Type) return Hash_Type; diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb index df7821d74b9..cab0c09bc35 100644 --- a/gcc/ada/a-chtgke.adb +++ b/gcc/ada/a-chtgke.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +29,10 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Checked_Equivalent_Keys -- ----------------------------- @@ -38,28 +42,9 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is Key : Key_Type; Node : Node_Access) return Boolean is - Result : Boolean; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Equivalent_Keys (Key, Node); - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Equivalent_Keys (Key, Node); end Checked_Equivalent_Keys; ------------------- @@ -70,28 +55,9 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is (HT : aliased in out Hash_Table_Type; Key : Key_Type) return Hash_Type is - Result : Hash_Type; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Hash (Key) mod HT.Buckets'Length; - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Hash (Key) mod HT.Buckets'Length; end Checked_Index; -------------------------- @@ -115,10 +81,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Indx := Checked_Index (HT, Key); X := HT.Buckets (Indx); @@ -128,10 +91,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is end if; if Checked_Equivalent_Keys (HT, Key, X) then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); HT.Buckets (Indx) := Next (X); HT.Length := HT.Length - 1; return; @@ -146,10 +106,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is end if; if Checked_Equivalent_Keys (HT, Key, X) then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Set_Next (Node => Prev, Next => Next (X)); HT.Length := HT.Length - 1; return; @@ -202,16 +159,13 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Indx := Checked_Index (HT, Key); Node := HT.Buckets (Indx); if Node = null then - if HT.Length = Count_Type'Last then + if Checks and then HT.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -235,7 +189,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is exit when Node = null; end loop; - if HT.Length = Count_Type'Last then + if Checks and then HT.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -269,31 +223,13 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- element tampering by a generic actual subprogram. declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Old_Indx := Hash (Node) mod HT.Buckets'Length; - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; if Checked_Equivalent_Keys (HT, Key, Node) then - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (container is locked)"; - end if; + TE_Check (HT.TC); -- We can change a node's key to Key (that's what Assign is for), but -- only if Key is not already in the hash table. (In a unique-key @@ -312,7 +248,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is N := New_Bucket; while N /= null loop - if Checked_Equivalent_Keys (HT, Key, N) then + if Checks and then Checked_Equivalent_Keys (HT, Key, N) then pragma Assert (N /= Node); raise Program_Error with "attempt to replace existing element"; @@ -332,10 +268,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- The node is already in the bucket implied by Key. In this case -- we merely change its value without moving it. - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (container is locked)"; - end if; + TE_Check (HT.TC); Assign (Node, Key); return; @@ -343,10 +276,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- The node is a bucket different from the bucket implied by Key - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); -- Do the assignment first, before moving the node, so that if Assign -- propagates an exception, then the hash table will not have been diff --git a/gcc/ada/a-chtgke.ads b/gcc/ada/a-chtgke.ads index 37256e2eb59..00b31384587 100644 --- a/gcc/ada/a-chtgke.ads +++ b/gcc/ada/a-chtgke.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +34,7 @@ generic with package HT_Types is new Generic_Hash_Table_Types (<>); - use HT_Types; + use HT_Types, HT_Types.Implementation; with function Next (Node : Node_Access) return Node_Access; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index dda5f2cccf7..87a2e1eca83 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +34,10 @@ with System; use type System.Address; package body Ada.Containers.Hash_Tables.Generic_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + type Buckets_Allocation is access all Buckets_Type; -- Used for allocation and deallocation (see New_Buckets and Free_Buckets). -- This is necessary because Buckets_Access has an empty storage pool. @@ -130,28 +134,9 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Buckets : Buckets_Type; Node : Node_Access) return Hash_Type is - Result : Hash_Type; - - B : Natural renames Hash_Table.Busy; - L : Natural renames Hash_Table.Lock; - + Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Index (Buckets, Node); - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Index (Buckets, Node); end Checked_Index; function Checked_Index @@ -171,10 +156,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Node : Node_Access; begin - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); while HT.Length > 0 loop while HT.Buckets (Index) = null loop @@ -217,7 +199,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; - if HT.Length = 1 then + if Checks and then HT.Length = 1 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -225,7 +207,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is loop Curr := Next (Prev); - if Curr = null then + if Checks and then Curr = null then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -256,7 +238,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Curr : Node_Access; begin - if HT.Length = 0 then + if Checks and then HT.Length = 0 then raise Program_Error with "attempt to delete node from empty hashed container"; end if; @@ -264,7 +246,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Indx := Checked_Index (HT, X); Prev := HT.Buckets (Indx); - if Prev = null then + if Checks and then Prev = null then raise Program_Error with "attempt to delete node from empty hash bucket"; end if; @@ -275,7 +257,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; - if HT.Length = 1 then + if Checks and then HT.Length = 1 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -283,7 +265,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is loop Curr := Next (Prev); - if Curr = null then + if Checks and then Curr = null then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -375,13 +357,11 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is function Generic_Equal (L, R : Hash_Table_Type) return Boolean is - BL : Natural renames L'Unrestricted_Access.Busy; - LL : Natural renames L'Unrestricted_Access.Lock; - - BR : Natural renames R'Unrestricted_Access.Busy; - LR : Natural renames R'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Result : Boolean; + Lock_L : With_Lock (L.TC'Unrestricted_Access); + Lock_R : With_Lock (R.TC'Unrestricted_Access); L_Index : Hash_Type; L_Node : Node_Access; @@ -410,23 +390,13 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is L_Index := L_Index + 1; end loop; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - -- For each node of hash table L, search for an equivalent node in hash -- table R. N := L.Length; loop if not Find (HT => R, Key => L_Node) then - Result := False; - exit; + return False; end if; N := N - 1; @@ -437,8 +407,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is -- We have exhausted the nodes in this bucket if N = 0 then - Result := True; - exit; + return True; end if; -- Find the next bucket @@ -450,24 +419,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end loop; end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end Generic_Equal; ----------------------- @@ -507,7 +458,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Count_Type'Base'Read (Stream, N); - if N < 0 then + if Checks and then N < 0 then raise Program_Error with "stream appears to be corrupt"; end if; @@ -600,10 +551,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Clear (Target); @@ -745,10 +693,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end if; end if; - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Rehash : declare Dst_Buckets : Buckets_Access := New_Buckets (Length => NN); diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads index 70e1535c86a..4a7fbd6c743 100644 --- a/gcc/ada/a-chtgop.ads +++ b/gcc/ada/a-chtgop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,7 +37,7 @@ generic with package HT_Types is new Generic_Hash_Table_Types (<>); - use HT_Types; + use HT_Types, HT_Types.Implementation; with function Hash_Node (Node : Node_Access) return Hash_Type; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 6e296e80c2d..d7995e3e98a 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +35,10 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); @@ -72,64 +76,32 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L : Node_Access; R : Node_Access; - Result : Boolean; begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Length /= Right.Length then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L := Left.First; R := Right.First; - Result := True; for J in 1 .. Left.Length loop if L.Element.all /= R.Element.all then - Result := False; - exit; + return False; end if; L := L.Next; R := R.Next; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + return True; end "="; ------------ @@ -144,8 +116,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Src = null then pragma Assert (Container.Last = null); pragma Assert (Container.Length = 0); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; @@ -156,8 +127,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.First := null; Container.Last := null; Container.Length := 0; - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); declare Element : Element_Access := new Element_Type'(Src.Element.all); @@ -193,20 +163,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end loop; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List 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; - ------------ -- Append -- ------------ @@ -254,18 +210,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Container.Length = 0 then pragma Assert (Container.First = null); pragma Assert (Container.Last = null); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); while Container.Length > 1 loop X := Container.First; @@ -298,32 +250,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - elsif Position.Node.Element = null then + end if; + + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; -------------- @@ -361,17 +314,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is X : Node_Access; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -389,10 +343,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for Index in 1 .. Count loop X := Position.Node; @@ -435,27 +386,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Count >= Container.Length then Clear (Container); return; + end if; - elsif Count = 0 then + if Count = 0 then return; + end if; - elsif Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + TC_Check (Container.TC); - else - for J in 1 .. Count loop - X := Container.First; - pragma Assert (X.Next.Prev = Container.First); + for J in 1 .. Count loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); - Container.First := X.Next; - Container.First.Prev := null; + Container.First := X.Next; + Container.First.Prev := null; - Container.Length := Container.Length - 1; + Container.Length := Container.Length - 1; - Free (X); - end loop; - end if; + Free (X); + end loop; end Delete_First; ----------------- @@ -472,27 +421,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Count >= Container.Length then Clear (Container); return; + end if; - elsif Count = 0 then + if Count = 0 then return; + end if; - elsif Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + TC_Check (Container.TC); - else - for J in 1 .. Count loop - X := Container.Last; - pragma Assert (X.Prev.Next = Container.Last); + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (X.Prev.Next = Container.Last); - Container.Last := X.Prev; - Container.Last.Next := null; + Container.Last := X.Prev; + Container.Last.Next := null; - Container.Length := Container.Length - 1; + Container.Length := Container.Length - 1; - Free (X); - end loop; - end if; + Free (X); + end loop; end Delete_Last; ------------- @@ -501,19 +448,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Element"); + pragma Assert (Vet (Position), "bad cursor in Element"); - return Position.Node.Element.all; - end if; + return Position.Node.Element.all; end Element; -------------- @@ -523,27 +470,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List 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; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -563,56 +490,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Node := Container.First; else - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - - else - pragma Assert (Vet (Position), "bad cursor in Find"); end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); end if; -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Node_Access; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := null; while Node /= null loop if Node.Element.all = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Next; end loop; - B := B - 1; - L := L - 1; - - if Result = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Find; @@ -657,11 +562,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function First_Element (Container : List) return Element_Type is begin - if Container.First = null then + if Checks and then Container.First = null then raise Constraint_Error with "list is empty"; - else - return Container.First.Element.all; end if; + + return Container.First.Element.all; end First_Element; ---------- @@ -716,41 +621,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Node : Node_Access; - Result : Boolean; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; + Lock : With_Lock (Container.TC'Unrestricted_Access); + Node : Node_Access; + begin Node := Container.First; - Result := True; for J in 2 .. Container.Length loop if Node.Next.Element.all < Node.Element.all then - Result := False; - exit; + return False; end if; Node := Node.Next; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return True; end Is_Sorted; ----------- @@ -772,39 +659,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Source.Is_Empty then return; + end if; - elsif Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; + end if; - elsif Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length + then raise Constraint_Error with "new length exceeds maximum"; - - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; end if; - declare - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; + TC_Check (Target.TC); + TC_Check (Source.TC); - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; + declare + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); LI, RI, RJ : Node_Access; begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - LI := Target.First; RI := Source.First; while RI /= null loop @@ -830,22 +706,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is LI := LI.Next; end if; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -929,33 +789,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Front => null, Back => null); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; pragma Assert (Container.First.Prev = null); @@ -964,6 +806,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -990,17 +842,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + "Before cursor designates wrong list"; + end if; - elsif Before.Node = null or else Before.Node.Element = null then + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then raise Program_Error with "Before cursor has no element"; - - else - pragma Assert (Vet (Before), "bad cursor in Insert"); end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then @@ -1008,14 +863,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Container.Length > Count_Type'Last - Count then + if Checks and then Container.Length > Count_Type'Last - Count then raise Constraint_Error with "new length exceeds maximum"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -1134,32 +986,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Node_Access := Container.First; begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Next; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Next; + end loop; end Iterate; function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1176,7 +1016,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1185,8 +1025,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1199,34 +1037,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; + end if; - elsif Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong list"; - - else - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the - -- First and Last selector functions of the iterator object. When - -- the Node component is non-null (as is the case here), it means - -- that this is a partial iteration, over a subset of the complete - -- sequence of items. The iterator object was constructed with - -- a start expression, indicating the position from which the - -- iteration begins. Note that the start position has the same value - -- irrespective of whether this is a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - B := B + 1; - end return; end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the + -- First and Last selector functions of the iterator object. When + -- the Node component is non-null (as is the case here), it means + -- that this is a partial iteration, over a subset of the complete + -- sequence of items. The iterator object was constructed with + -- a start expression, indicating the position from which the + -- iteration begins. Note that the start position has the same value + -- irrespective of whether this is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; end Iterate; ---------- @@ -1270,11 +1108,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type is begin - if Container.Last = null then + if Checks and then Container.Last = null then raise Constraint_Error with "list is empty"; - else - return Container.Last.Element.all; end if; + + return Container.Last.Element.all; end Last_Element; ------------ @@ -1294,23 +1132,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Target'Address = Source'Address then return; + end if; - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Source.TC); - else - Clear (Target); + Clear (Target); - Target.First := Source.First; - Source.First := null; + Target.First := Source.First; + Source.First := null; - Target.Last := Source.Last; - Source.Last := null; + Target.Last := Source.Last; + Source.Last := null; - Target.Length := Source.Length; - Source.Length := 0; - end if; + Target.Length := Source.Length; + Source.Length := 0; end Move; ---------- @@ -1346,12 +1181,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; - else - return Next (Position); end if; + + return Next (Position); end Next; ------------- @@ -1400,14 +1237,30 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; - else - return Previous (Position); end if; + + return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1417,39 +1270,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + pragma Assert (Vet (Position), "bad cursor in Query_Element"); - L := L - 1; - B := B - 1; - end; - end if; + declare + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); + begin + Process (Position.Node.Element.all); + end; end Query_Element; ---------- @@ -1538,33 +1375,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; + end if; - elsif Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in function Reference"); + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- @@ -1577,38 +1414,37 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is New_Item : Element_Type) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; + TE_Check (Container.TC); - elsif Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - declare - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). - pragma Unsuppress (Accessibility_Check); + pragma Unsuppress (Accessibility_Check); - X : Element_Access := Position.Node.Element; + X : Element_Access := Position.Node.Element; - begin - Position.Node.Element := new Element_Type'(New_Item); - Free (X); - end; - end if; + begin + Position.Node.Element := new Element_Type'(New_Item); + Free (X); + end; end Replace_Element; ---------------------- @@ -1669,10 +1505,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); Container.First := J; Container.Last := I; @@ -1714,56 +1547,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Node := Container.Last; else - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - - else - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Node_Access; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := null; while Node /= null loop if Node.Element.all = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; end loop; - B := B - 1; - L := L - 1; - - if Result = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Reverse_Find; @@ -1775,26 +1586,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Node_Access := Container.Last; begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Prev; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Prev; + end loop; end Reverse_Iterate; ------------ @@ -1808,36 +1607,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; + end if; - elsif Before.Node = null or else Before.Node.Element = null then + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then raise Program_Error with "Before cursor has no element"; - - else - pragma Assert (Vet (Before), "bad cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad cursor in Splice"); end if; if Target'Address = Source'Address or else Source.Length = 0 then return; + end if; - elsif Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Target.TC); + TC_Check (Source.TC); - else - Splice_Internal (Target, Before.Node, Source); - end if; + Splice_Internal (Target, Before.Node, Source); end Splice; procedure Splice @@ -1847,28 +1643,31 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Container'Unchecked_Access then + if Checks and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; + end if; - elsif Before.Node = null or else Before.Node.Element = null then + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then raise Program_Error with "Before cursor has no element"; - - else - pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -1883,10 +1682,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); if Before.Node = null then pragma Assert (Position.Node /= Container.Last); @@ -1964,13 +1760,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; end if; - if Before.Node = null - or else Before.Node.Element = null + if Checks and then + (Before.Node = null or else Before.Node.Element = null) then raise Program_Error with "Before cursor has no element"; @@ -1979,35 +1775,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); - if Target.Length = Count_Type'Last then + if Checks and then Target.Length = Count_Type'Last then raise Constraint_Error with "Target is full"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); Splice_Internal (Target, Before.Node, Source, Position.Node); Position.Container := Target'Unchecked_Access; @@ -2165,19 +1954,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null then + if Checks and then I.Node = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = null then + if Checks and then J.Node = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unchecked_Access then + if Checks and then I.Container /= Container'Unchecked_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unchecked_Access then + if Checks and then J.Container /= Container'Unchecked_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2185,10 +1974,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; - end if; + TE_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (J), "bad J cursor in Swap"); @@ -2211,19 +1997,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null then + if Checks and then I.Node = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = null then + if Checks and then J.Node = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2231,10 +2017,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (J), "bad J cursor in Swap_Links"); @@ -2278,16 +2061,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -2295,24 +2078,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Update_Element"); declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element.all); end; end Update_Element; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index 932fecbf326..46354afa19e 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +private with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -240,10 +241,14 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Node_Type; type Node_Access is access Node_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record @@ -257,11 +262,10 @@ private type List is new Controlled with record - First : Node_Access; - Last : Node_Access; + First : Node_Access := null; + Last : Node_Access := null; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; overriding procedure Adjust (Container : in out List); @@ -301,16 +305,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : List_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -356,7 +352,23 @@ private for Reference_Type'Read use Read; - Empty_List : constant List := List'(Controlled with null, null, 0, 0, 0); + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_List : constant List := List'(Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -365,7 +377,8 @@ private record Container : List_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 98798a247a7..2cea3189511 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +33,8 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Unchecked_Deallocation; with System; use type System.Address; @@ -41,6 +43,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + procedure Free_Key is new Ada.Unchecked_Deallocation (Key_Type, Key_Access); @@ -124,21 +130,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is HT_Ops.Adjust (Container.HT); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - M : Map renames Control.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -201,17 +192,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; @@ -223,15 +215,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare M : Map renames Position.Container.all; HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -244,24 +235,23 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "key has no element"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -292,7 +282,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -330,7 +320,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is begin Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in map"; end if; @@ -339,20 +329,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; - if Container.HT.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with cursors (map is busy)"; - end if; + TC_Check (Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -371,7 +359,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "no element available because key not in map"; end if; @@ -381,12 +369,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor of function Element is bad"; end if; @@ -414,22 +402,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor of Equivalent_Keys is bad"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor of Equivalent_Keys is bad"; end if; @@ -445,12 +433,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor of Equivalent_Keys is bad"; end if; @@ -465,12 +453,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor of Equivalent_Keys is bad"; end if; @@ -503,28 +491,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.HT.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - M : Map renames Control.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.HT.TC); end if; end Finalize; @@ -631,6 +598,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Deallocate (X); end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -669,10 +646,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.HT.TC); K := Position.Node.Key; E := Position.Node.Element; @@ -774,7 +748,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert key already in map"; end if; @@ -812,33 +786,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); -- Start of processing Iterate begin - B := B + 1; - - begin - Local_Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container.HT); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; begin return It : constant Iterator := (Limited_Controlled with Container => Container'Unrestricted_Access) do - B := B + 1; + Busy (Container.HT.TC'Unrestricted_Access.all); end return; end Iterate; @@ -848,12 +811,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; - if Position.Node.Key = null then + if Checks and then Position.Node.Key = null then raise Program_Error with "Position cursor of function Key is bad"; end if; @@ -904,8 +867,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return No_Element; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Next is bad"; end if; @@ -930,7 +893,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -938,6 +901,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return Next (Position); end Next; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -948,13 +926,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Query_Element is bad"; @@ -965,31 +943,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare M : Map renames Position.Container.all; HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - - begin - Process (K, E); - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Query_Element; @@ -1070,17 +1028,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; @@ -1092,15 +1051,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare M : Map renames Position.Container.all; HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1113,24 +1071,23 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "key has no element"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1150,15 +1107,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is E : Element_Access; begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in map"; end if; - if Container.HT.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.HT.TC); K := Node.Key; E := Node.Element; @@ -1195,27 +1149,25 @@ package body Ada.Containers.Indefinite_Hashed_Maps is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Replace_Element is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Position.Container.HT.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Position.Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -1266,19 +1218,20 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Update_Element is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1287,30 +1240,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare HT : Hash_Table_Type renames Container.HT; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - - begin - Process (K, E); - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Update_Element; diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index a224b3c5454..e0584a86a43 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -312,7 +312,7 @@ private type Node_Access is access Node_Type; type Key_Access is access Key_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record Key : Key_Access; @@ -331,7 +331,7 @@ private overriding procedure Finalize (Container : in out Map); - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -367,16 +367,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Map_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -422,7 +414,23 @@ private for Reference_Type'Read use Read; - Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := (Controlled with others => <>); No_Element : constant Cursor := (Container => null, Node => null); @@ -430,7 +438,8 @@ private Map_Iterator_Interfaces.Forward_Iterator with record Container : Map_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 4cc0f461b40..655304fa862 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +35,8 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Prime_Numbers; with System; use type System.Address; @@ -43,6 +45,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -155,20 +161,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -224,16 +216,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -241,15 +234,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -280,7 +272,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -318,7 +310,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -330,22 +322,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if Container.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.HT.TC); pragma Assert (Vet (Position), "Position cursor is bad"); @@ -376,10 +366,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); if Src_HT.Length < Target.HT.Length then declare @@ -495,7 +482,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end Iterate_Left; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Difference; ------------- @@ -504,11 +491,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of equals No_Element"; end if; - if Position.Node.Element = null then -- handle dangling reference + if Checks and then Position.Node.Element = null then + -- handle dangling reference raise Program_Error with "Position cursor is bad"; end if; @@ -532,22 +520,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Equivalent_Elements (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor of Equivalent_Elements is bad"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor of Equivalent_Elements is bad"; end if; @@ -579,12 +567,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor of Equivalent_Elements is bad"; end if; @@ -599,12 +587,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor of Equivalent_Elements is bad"; end if; @@ -652,27 +640,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.HT.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.HT.TC); end if; end Finalize; @@ -789,6 +757,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Deallocate (X); end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -825,10 +803,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.HT.TC); X := Position.Node.Element; @@ -874,7 +849,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -950,10 +925,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop @@ -1048,7 +1020,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end Iterate_Left; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Intersection; -------------- @@ -1128,34 +1100,23 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Iterate (Container.HT); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; begin return It : constant Iterator := Iterator'(Limited_Controlled with Container => Container'Unrestricted_Access) do - B := B + 1; + Busy (Container.HT.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1192,7 +1153,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return No_Element; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "bad cursor in Next"; end if; @@ -1221,7 +1182,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1259,6 +1220,21 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return False; end Overlap; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1268,12 +1244,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "bad cursor in Query_Element"; end if; @@ -1282,25 +1258,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container'Unrestricted_Access.all.HT; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element.all); end; end Query_Element; @@ -1363,15 +1323,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is pragma Warnings (Off, X); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.HT.TC); X := Node.Element; @@ -1399,15 +1356,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "bad cursor in Replace_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1448,26 +1406,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is is Tgt_HT : Hash_Table_Type renames Target.HT; Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - TB : Natural renames Tgt_HT.Busy; - TL : Natural renames Tgt_HT.Lock; - - SB : Natural renames Src_HT.Busy; - SL : Natural renames Src_HT.Lock; - begin if Target'Address = Source'Address then Clear (Target); return; end if; - if TB > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Tgt_HT.TC); declare N : constant Count_Type := Target.Length + Source.Length; @@ -1507,32 +1452,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is N := N + 1; end Process; - -- Start of processing for Iterate_Source_When_Empty_Target + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. - begin - TB := TB + 1; - TL := TL + 1; + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - SB := SB + 1; - SL := SL + 1; + -- Start of processing for Iterate_Source_When_Empty_Target + begin Iterate (Src_HT); - - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - exception - when others => - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - raise; end Iterate_Source_When_Empty_Target; else @@ -1608,32 +1537,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; end Process; - -- Start of processing for Iterate_Source + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. - begin - TB := TB + 1; - TL := TL + 1; + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - SB := SB + 1; - SL := SL + 1; + -- Start of processing for Iterate_Source + begin Iterate (Src_HT); - - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - exception - when others => - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - raise; end Iterate_Source; end if; end Symmetric_Difference; @@ -1767,7 +1680,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end Iterate_Right; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Symmetric_Difference; ------------ @@ -1841,10 +1754,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); declare N : constant Count_Type := Target.Length + Source.Length; @@ -1911,25 +1821,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Checked_Index instead of a simple invocation of generic formal -- Hash. - B : Integer renames Left_HT.Busy; - L : Integer renames Left_HT.Lock; + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); -- Start of processing for Iterate_Left begin - B := B + 1; - L := L + 1; - - Iterate (Left.HT); - - L := L - 1; - B := B - 1; - + Iterate (Left_HT); exception when others => - L := L - 1; - B := B - 1; - HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Left; @@ -1978,42 +1877,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Checked_Index instead of a simple invocation of generic formal -- Hash. - LB : Integer renames Left_HT.Busy; - LL : Integer renames Left_HT.Lock; - - RB : Integer renames Right_HT.Busy; - RL : Integer renames Right_HT.Lock; + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); -- Start of processing for Iterate_Right begin - LB := LB + 1; - LL := LL + 1; - - RB := RB + 1; - RL := RL + 1; - Iterate (Right.HT); - - RL := RL - 1; - RB := RB - 1; - - LL := LL - 1; - LB := LB - 1; - exception when others => - RL := RL - 1; - RB := RB - 1; - - LL := LL - 1; - LB := LB - 1; - HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Right; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Union; --------- @@ -2141,24 +2018,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Hash => Hash, Equivalent_Keys => Equivalent_Key_Node); - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------------------ -- Constant_Reference -- ------------------------ @@ -2171,24 +2030,23 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -2218,7 +2076,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "key not in set"; end if; @@ -2237,7 +2095,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; @@ -2276,16 +2134,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; + Impl.Reference_Control_Type (Control).Finalize; - if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then + if Checks and then Hash (Key (Control.Old_Pos)) /= Control.Old_Hash + then HT_Ops.Delete_Node_At_Index (Control.Container.HT, Control.Index, Control.Old_Pos.Node); raise Program_Error; @@ -2316,12 +2168,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -2351,16 +2203,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -2370,20 +2223,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Access, Control => (Controlled with + HT.TC'Unrestricted_Access, Container => Container'Access, Index => HT_Ops.Index (HT, Position.Node), Old_Pos => Position, Old_Hash => Hash (Key (Position)))) - do - B := B + 1; - L := L + 1; + do + Lock (HT.TC); end return; end; end Reference_Preserving_Key; @@ -2395,31 +2246,29 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; P : constant Cursor := Find (Container, Key); begin return R : constant Reference_Type := (Element => Node.Element.all'Access, Control => (Controlled with + HT.TC'Unrestricted_Access, Container => Container'Access, Index => HT_Ops.Index (HT, P.Node), Old_Pos => P, Old_Hash => Hash (Key))) do - B := B + 1; - L := L + 1; + Lock (HT.TC); end return; end; end Reference_Preserving_Key; @@ -2436,7 +2285,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -2458,25 +2307,28 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Indx : Hash_Type; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null - or else Position.Node.Next = Position.Node + if Checks and then + (Position.Node.Element = null + or else Position.Node.Next = Position.Node) then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if HT.Buckets = null - or else HT.Buckets'Length = 0 - or else HT.Length = 0 + if Checks and then + (HT.Buckets = null + or else HT.Buckets'Length = 0 + or else HT.Length = 0) then raise Program_Error with "Position cursor is bad (set is empty)"; end if; @@ -2491,33 +2343,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare E : Element_Type renames Position.Node.Element.all; K : constant Key_Type := Key (E); - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - - Eq : Boolean; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Indx := HT_Ops.Index (HT, Position.Node); - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; - - L := L - 1; - B := B - 1; + Indx := HT_Ops.Index (HT, Position.Node); + Process (E); - if Eq then + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -2533,7 +2364,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is while Prev.Next /= Position.Node loop Prev := Prev.Next; - if Prev = null then + if Checks and then Prev = null then raise Program_Error with "Position cursor is bad (node not found)"; end if; diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index f9ae2ac6220..db4d8bda9dc 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -34,6 +34,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; +private with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; @@ -433,8 +434,10 @@ package Ada.Containers.Indefinite_Hashed_Sets is type Set_Access is access all Set; for Set_Access'Storage_Size use 0; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Index : Hash_Type; @@ -442,9 +445,6 @@ package Ada.Containers.Indefinite_Hashed_Sets is 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); @@ -477,7 +477,7 @@ private type Node_Type; type Node_Access is access Node_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record Element : Element_Access; @@ -495,7 +495,7 @@ private overriding procedure Finalize (Container : in out Set); - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -531,16 +531,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Set_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -564,7 +556,23 @@ private for Constant_Reference_Type'Write use Write; - Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0)); + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := (Controlled with others => <>); No_Element : constant Cursor := (Container => null, Node => null); @@ -572,7 +580,8 @@ private Set_Iterator_Interfaces.Forward_Iterator with record Container : Set_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index e0b4b968257..326c1172c8f 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +35,10 @@ package body Ada.Containers.Indefinite_Multiway_Trees is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + -------------------- -- Root_Iterator -- -------------------- @@ -164,10 +168,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is function "=" (Left, Right : Tree) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - return Equal_Children (Root_Node (Left), Root_Node (Right)); end "="; @@ -186,8 +186,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- are preserved in the event that the allocation fails. Container.Root.Children := Children_Type'(others => null); - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); Container.Count := 0; -- Copy_Children returns a count of the number of nodes that it @@ -206,20 +205,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Container.Count := Source_Count; 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; - ------------------- -- Ancestor_Find -- ------------------- @@ -231,13 +216,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is R, N : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Commented-out pending ARG ruling. ??? - -- if Position.Container /= Container'Unrestricted_Access then + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then -- raise Program_Error with "Position cursor not in container"; -- end if; @@ -245,7 +232,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- 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.??? - -- if Is_Root (Position) then + -- if Checks and then Is_Root (Position) then -- raise Program_Error with "Position cursor designates root"; -- end if; @@ -276,11 +263,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Element : Element_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -288,10 +275,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -406,15 +390,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is N : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Child = No_Element then + if Checks and then Child = No_Element then raise Constraint_Error with "Child cursor has no element"; end if; - if Parent.Container /= Child.Container then + if Checks and then Parent.Container /= Child.Container then raise Program_Error with "Parent and Child in different containers"; end if; @@ -424,7 +408,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Result := Result + 1; N := N.Parent; - if N = null then + if Checks and then N = null then raise Program_Error with "Parent is not ancestor of Child"; end if; end loop; @@ -441,10 +425,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Children_Count : Count_Type; begin - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); -- We first set the container count to 0, in order to preserve -- invariants in case the deallocation fails. (This works because @@ -478,21 +459,22 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -501,16 +483,14 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- "Position cursor in Constant_Reference is bad"); declare - C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -615,20 +595,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Target_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; @@ -637,7 +617,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Is_Root (Source) then + if Checks and then Is_Root (Source) then raise Constraint_Error with "Source cursor designates root"; end if; @@ -760,18 +740,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); -- Deallocate_Children returns a count of the number of nodes -- that it deallocates, but it works by incrementing the @@ -797,26 +774,24 @@ package body Ada.Containers.Indefinite_Multiway_Trees is X : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if not Is_Leaf (Position) then + if Checks and then not Is_Leaf (Position) then raise Constraint_Error with "Position cursor does not designate leaf"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -846,22 +821,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Count : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -924,11 +897,12 @@ package body Ada.Containers.Indefinite_Multiway_Trees is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node = Root_Node (Position.Container.all) then + if Checks and then Position.Node = Root_Node (Position.Container.all) + then raise Program_Error with "Position cursor designates root"; end if; @@ -976,11 +950,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Right_Position : Cursor) return Boolean is begin - if Left_Position = No_Element then + if Checks and then Left_Position = No_Element then raise Constraint_Error with "Left cursor has no element"; end if; - if Right_Position = No_Element then + if Checks and then Right_Position = No_Element then raise Constraint_Error with "Right cursor has no element"; end if; @@ -1020,25 +994,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -------------- procedure Finalize (Object : in out Root_Iterator) is - B : Natural renames Object.Container.Busy; - begin - 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; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -1086,7 +1043,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Node : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1144,13 +1101,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Result : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Commented-out pending ruling from ARG. ??? - -- if Position.Container /= Container'Unrestricted_Access then + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then -- raise Program_Error with "Position cursor not in container"; -- end if; @@ -1180,6 +1139,16 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return Find_In_Children (Subtree, Item); end Find_In_Subtree; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1224,20 +1193,21 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Element : Element_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1247,10 +1217,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -1437,22 +1404,12 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - Iterate_Children (Container => Container'Unrestricted_Access, Subtree => Root_Node (Container), Process => Process); - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end Iterate; function Iterate (Container : Tree) @@ -1470,31 +1427,18 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Parent : Cursor; Process : not null access procedure (Position : Cursor)) is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - declare - B : Natural renames Parent.Container.Busy; - C : Tree_Node_Access; - - begin - B := B + 1; - - C := Parent.Node.Children.First; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Next; - end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + C := Parent.Node.Children.First; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Next; + end loop; end Iterate_Children; procedure Iterate_Children @@ -1524,14 +1468,12 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return Tree_Iterator_Interfaces.Reversible_Iterator'Class is C : constant Tree_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= C then + if Checks and then Parent.Container /= C then raise Program_Error with "Parent cursor not in container"; end if; @@ -1540,7 +1482,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Container => C, Subtree => Parent.Node) do - B := B + 1; + Busy (C.TC); end return; end Iterate_Children; @@ -1552,55 +1494,39 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + C : constant Tree_Access := Position.Container; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Implement Vet for multiway trees??? -- pragma Assert (Vet (Position), "bad subtree cursor"); - declare - B : Natural renames Position.Container.Busy; - begin - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => Position.Container, - Subtree => Position.Node) - do - B := B + 1; - end return; - end; + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + Busy (C.TC); + end return; end Iterate_Subtree; procedure Iterate_Subtree (Position : Cursor; Process : not null access procedure (Position : Cursor)) is + Busy : With_Busy (Position.Container.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - declare - B : Natural renames Position.Container.Busy; - - begin - B := B + 1; - - if Is_Root (Position) then - Iterate_Children (Position.Container, Position.Node, Process); - else - Iterate_Subtree (Position.Container, Position.Node, Process); - end if; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + if Is_Root (Position) then + Iterate_Children (Position.Container, Position.Node, Process); + else + Iterate_Subtree (Position.Container, Position.Node, Process); + end if; end Iterate_Subtree; procedure Iterate_Subtree @@ -1634,7 +1560,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Node : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1668,10 +1594,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors of Source (tree is busy)"; - end if; + TC_Check (Source.TC); Target.Clear; -- checks busy bit @@ -1703,7 +1626,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -1734,7 +1657,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -1814,11 +1737,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Element : Element_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -1826,10 +1749,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -1889,7 +1809,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong tree"; end if; @@ -1919,6 +1839,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position := Previous_Sibling (Position); end Previous_Sibling; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1927,35 +1861,18 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - - begin - B := B + 1; - L := L + 1; - - Process (Position.Node.Element.all); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + Process (Position.Node.Element.all); end Query_Element; ---------- @@ -1994,7 +1911,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is begin Count_Type'Read (Stream, Count); - if Count < 0 then + if Checks and then Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2046,7 +1963,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Count_Type'Read (Stream, Total_Count); - if Total_Count < 0 then + if Checks and then Total_Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2058,7 +1975,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Read_Children (Root_Node (Container)); - if Read_Count /= Total_Count then + if Checks and then Read_Count /= Total_Count then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2098,21 +2015,22 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -2121,16 +2039,14 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- "Position cursor in Constant_Reference is bad"); declare - C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -2182,22 +2098,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is E, X : Element_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -2224,31 +2138,18 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Parent : Cursor; Process : not null access procedure (Position : Cursor)) is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - declare - B : Natural renames Parent.Container.Busy; - C : Tree_Node_Access; - - begin - B := B + 1; - - C := Parent.Node.Children.Last; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Prev; - end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + C := Parent.Node.Children.Last; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Prev; + end loop; end Reverse_Iterate_Children; ---------- @@ -2283,32 +2184,34 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Count : Count_Type; begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Target'Unrestricted_Access then + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Before.Node.Parent /= Target_Parent.Node then + if Checks and then Before.Node.Parent /= Target_Parent.Node then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Source'Unrestricted_Access then + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in Source container"; end if; @@ -2318,12 +2221,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (From => Target_Parent.Node, + if Checks and then Is_Reachable (From => Target_Parent.Node, To => Source_Parent.Node) then raise Constraint_Error @@ -2338,15 +2238,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- We cache the count of the nodes we have allocated, so that operation -- Node_Count can execute in O(1) time. But that means we must count the @@ -2374,32 +2267,37 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Source_Parent : Cursor) is begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Target_Parent.Node then + if Checks and then Before.Node.Parent /= Target_Parent.Node then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in container"; end if; @@ -2408,12 +2306,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (From => Target_Parent.Node, + if Checks and then Is_Reachable (From => Target_Parent.Node, To => Source_Parent.Node) then raise Constraint_Error @@ -2470,33 +2365,33 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Subtree_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor not in Source container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; @@ -2511,12 +2406,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (From => Parent.Node, To => Position.Node) then + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then raise Constraint_Error with "Position is ancestor of Parent"; end if; @@ -2528,15 +2422,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- This is an unfortunate feature of this API: we must count the nodes -- in the subtree that we remove from the source tree, which is an O(n) @@ -2570,33 +2457,35 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then -- Should this be PE instead? Need ARG confirmation. ??? @@ -2613,12 +2502,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (From => Parent.Node, To => Position.Node) then + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then raise Constraint_Error with "Position is ancestor of Parent"; end if; @@ -2667,15 +2555,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is I, J : Cursor) is begin - if I = No_Element then + if Checks and then I = No_Element then raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor not in container"; end if; - if Is_Root (I) then + if Checks and then Is_Root (I) then raise Program_Error with "I cursor designates root"; end if; @@ -2683,22 +2571,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if J = No_Element then + if Checks and then J = No_Element then raise Constraint_Error with "J cursor has no element"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor not in container"; end if; - if Is_Root (J) then + if Checks and then Is_Root (J) then raise Program_Error with "J cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); declare EI : constant Element_Access := I.Node.Element; @@ -2718,40 +2603,23 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - - begin - B := B + 1; - L := L + 1; - - Process (Position.Node.Element.all); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; + Process (Position.Node.Element.all); end Update_Element; ----------- diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads index 48d2d5fabd4..dd636511ea4 100644 --- a/gcc/ada/a-cimutr.ads +++ b/gcc/ada/a-cimutr.ads @@ -32,6 +32,8 @@ ------------------------------------------------------------------------------ with Ada.Iterator_Interfaces; + +private with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -303,6 +305,10 @@ package Ada.Containers.Indefinite_Multiway_Trees is private + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Tree_Node_Type; type Tree_Node_Access is access all Tree_Node_Type; @@ -311,7 +317,7 @@ private Last : Tree_Node_Access; end record; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Tree_Node_Type is record Parent : Tree_Node_Access; @@ -337,8 +343,7 @@ private type Tree is new Controlled with record Root : aliased Tree_Node_Type; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; Count : Count_Type := 0; end record; @@ -380,16 +385,8 @@ private for Cursor'Read use Read; - 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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -435,6 +432,22 @@ private for Reference_Type'Write use Write; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Tree : constant Tree := (Controlled with others => <>); No_Element : constant Cursor := (others => <>); diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index d06d8fedc1d..3d4a92f7f2e 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); @@ -41,6 +43,10 @@ package body Ada.Containers.Indefinite_Ordered_Maps is pragma Annotate (CodePeer, Skip_Analysis); pragma Suppress (All_Checks); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -132,19 +138,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor in ""<"" is bad"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor in ""<"" is bad"; end if; @@ -159,11 +165,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function "<" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor in ""<"" is bad"; end if; @@ -175,11 +181,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function "<" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor in ""<"" is bad"; end if; @@ -204,19 +210,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor in ""<"" is bad"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor in ""<"" is bad"; end if; @@ -231,11 +237,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function ">" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor in ""<"" is bad"; end if; @@ -247,11 +253,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor in ""<"" is bad"; end if; @@ -272,20 +278,6 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Adjust (Container.Tree); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - T : Tree_Type renames Control.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -357,17 +349,18 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -375,16 +368,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is "Position cursor in Constant_Reference is bad"); declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -396,25 +387,23 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -473,18 +462,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Delete is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; @@ -502,7 +492,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is X : Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "key not in map"; end if; @@ -542,12 +532,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor of function Element is bad"; end if; @@ -562,7 +552,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; @@ -598,27 +588,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Tree.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - T : Tree_Type renames Control.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.Tree.TC); end if; end Finalize; @@ -673,11 +643,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function First_Element (Container : Map) return Element_Type is T : Tree_Type renames Container.Tree; begin - if T.First = null then + if Checks and then T.First = null then raise Constraint_Error with "map is empty"; - else - return T.First.Element.all; end if; + + return T.First.Element.all; end First_Element; --------------- @@ -687,11 +657,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function First_Key (Container : Map) return Key_Type is T : Tree_Type renames Container.Tree; begin - if T.First = null then + if Checks and then T.First = null then raise Constraint_Error with "map is empty"; - else - return T.First.Key.all; end if; + + return T.First.Key.all; end First_Key; ----------- @@ -754,6 +724,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Deallocate (X); end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -782,10 +762,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); K := Position.Node.Key; E := Position.Node.Element; @@ -886,7 +863,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "key already in map"; end if; end Insert; @@ -959,30 +936,17 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container.Tree); - - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container.Tree); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -999,7 +963,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1008,8 +972,6 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1022,12 +984,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong map"; end if; @@ -1049,7 +1011,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1059,12 +1021,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; - if Position.Node.Key = null then + if Checks and then Position.Node.Key = null then raise Program_Error with "Position cursor of function Key is bad"; end if; @@ -1116,7 +1078,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is T : Tree_Type renames Container.Tree; begin - if T.Last = null then + if Checks and then T.Last = null then raise Constraint_Error with "map is empty"; end if; @@ -1131,7 +1093,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is T : Tree_Type renames Container.Tree; begin - if T.Last = null then + if Checks and then T.Last = null then raise Constraint_Error with "map is empty"; end if; @@ -1206,7 +1168,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -1262,7 +1224,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong map"; end if; @@ -1270,6 +1232,21 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1280,13 +1257,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Query_Element is bad"; @@ -1297,28 +1274,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Query_Element; @@ -1394,17 +1354,18 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -1412,16 +1373,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is "Position cursor in function Reference is bad"); declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1433,25 +1392,23 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1471,14 +1428,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is E : Element_Access; begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); K := Node.Key; E := Node.Element; @@ -1515,27 +1469,25 @@ package body Ada.Containers.Indefinite_Ordered_Maps is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Replace_Element is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); pragma Assert (Vet (Container.Tree, Position.Node), "Position cursor of Replace_Element is bad"); @@ -1578,22 +1530,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container.Tree); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (Container.Tree); end Reverse_Iterate; ----------- @@ -1652,19 +1594,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Update_Element is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1674,28 +1617,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Update_Element; diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index 2882a084bd2..62bd6878aa1 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -236,7 +236,7 @@ private type Node_Access is access Node_Type; type Key_Access is access Key_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record Parent : Node_Access; @@ -260,7 +260,7 @@ private overriding procedure Finalize (Container : in out Map) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -296,16 +296,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Map_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -351,13 +343,23 @@ private for Reference_Type'Write use Write; - Empty_Map : constant Map := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -366,7 +368,8 @@ private record Container : Map_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 38dd5ae6a40..8888e274bc3 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -44,6 +44,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -636,10 +640,8 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -------------- procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Tree.Busy; - pragma Assert (B > 0); begin - B := B - 1; + Unbusy (Object.Container.Tree.TC); end Finalize; ----------- @@ -943,22 +945,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T, Key); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T, Key); end Iterate; --------- @@ -1012,22 +1004,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T, Key); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T, Key); end Reverse_Iterate; -------------------- @@ -1061,25 +1043,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is declare E : Element_Type renames Node.Element.all; K : constant Key_Type := Key (E); - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (E); if Equivalent_Keys (Left => K, Right => Key (E)) then return; @@ -1367,22 +1333,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T, Item); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T, Item); end Iterate; procedure Iterate @@ -1405,30 +1361,18 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'Class is S : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames S.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1441,7 +1385,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := (Limited_Controlled with S, null) do - B := B + 1; + Busy (S.Tree.TC); end return; end Iterate; @@ -1449,8 +1393,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return Set_Iterator_Interfaces.Reversible_Iterator'Class is S : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames S.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1488,7 +1430,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return It : constant Iterator := (Limited_Controlled with S, Start.Node) do - B := B + 1; + Busy (S.Tree.TC); end return; end Iterate; @@ -1701,25 +1643,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element.all); end; end Query_Element; @@ -1792,10 +1718,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is then null; else - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); declare X : Element_Access := Node.Element; @@ -1914,22 +1837,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T, Item); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T, Item); end Reverse_Iterate; procedure Reverse_Iterate @@ -1952,22 +1865,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads index 7524cf7be3c..0663b67fec0 100644 --- a/gcc/ada/a-ciormu.ads +++ b/gcc/ada/a-ciormu.ads @@ -472,7 +472,7 @@ private overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -539,20 +539,15 @@ private for Constant_Reference_Type'Write use Write; - Empty_Set : constant Set := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + Empty_Set : constant Set := (Controlled with others => <>); type Iterator is new Limited_Controlled and Set_Iterator_Interfaces.Reversible_Iterator with record Container : Set_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 218ab8a325e..62b7c432d48 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); @@ -44,6 +46,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -147,19 +153,19 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor is bad"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor is bad"; end if; @@ -174,11 +180,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor is bad"; end if; @@ -190,11 +196,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor is bad"; end if; @@ -237,19 +243,19 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor is bad"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor is bad"; end if; @@ -266,11 +272,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor is bad"; end if; @@ -282,11 +288,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor is bad"; end if; @@ -307,20 +313,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Adjust (Container.Tree); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -377,16 +369,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -396,15 +389,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare Tree : Tree_Type renames Position.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -455,15 +447,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -478,12 +471,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Delete (Container : in out Set; Item : Element_Type) is X : Node_Access := Element_Keys.Find (Container.Tree, Item); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete element not in set"; - else - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); end if; + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); end Delete; ------------------ @@ -535,11 +528,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -615,27 +608,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Tree.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.Tree.TC); end if; end Finalize; @@ -692,11 +665,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function First_Element (Container : Set) return Element_Type is begin - if Container.Tree.First = null then + if Checks and then Container.Tree.First = null then raise Constraint_Error with "set is empty"; - else - return Container.Tree.First.Element.all; end if; + + return Container.Tree.First.Element.all; end First_Element; ----------- @@ -770,24 +743,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------- -- Ceiling -- ------------- @@ -810,25 +765,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -850,7 +804,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is X : Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -865,11 +819,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Element (Container : Set; Key : Key_Type) return Element_Type is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; - else - return Node.Element.all; end if; + + return Node.Element.all; end Element; --------------------- @@ -905,16 +859,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B - 1; - L := L - 1; - end; + Impl.Reference_Control_Type (Control).Finalize; - if not (Key (Control.Pos) = Control.Old_Key.all) then + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then Delete (Control.Container.all, Key (Control.Pos)); raise Program_Error; end if; @@ -976,12 +924,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -1004,7 +952,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -1033,16 +981,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -1052,19 +1001,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare Tree : Tree_Type renames Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Unchecked_Access, Control => (Controlled with + Tree.TC'Unrestricted_Access, Container => Container'Access, Pos => Position, Old_Key => new Key_Type'(Key (Position)))) do - B := B + 1; - L := L + 1; + Lock (Tree.TC); end return; end; end Reference_Preserving_Key; @@ -1076,29 +1023,27 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare Tree : Tree_Type renames Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; begin return R : constant Reference_Type := (Element => Node.Element.all'Unchecked_Access, Control => (Controlled with + Tree.TC'Unrestricted_Access, Container => Container'Access, Pos => Find (Container, Key), Old_Key => new Key_Type'(Key))) do - B := B + 1; - L := L + 1; + Lock (Tree.TC); end return; end; end Reference_Preserving_Key; @@ -1116,15 +1061,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Tree : Tree_Type renames Container.Tree; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1134,30 +1080,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare E : Element_Type renames Position.Node.Element.all; K : constant Key_Type := Key (E); - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - - Eq : Boolean; - + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Eq then + Process (E); + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -1186,6 +1112,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end Generic_Keys; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1199,7 +1135,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Include -- ------------- - procedure Include (Container : in out Set; New_Item : Element_Type) is + procedure Include (Container : in out Set; New_Item : Element_Type) is Position : Cursor; Inserted : Boolean; @@ -1209,10 +1145,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.Tree.TC); declare -- The element allocator may need an accessibility check in the @@ -1258,7 +1191,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -1470,30 +1403,18 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end Process_Node; T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1510,7 +1431,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1519,8 +1440,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1533,12 +1452,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong set"; end if; @@ -1560,7 +1479,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1603,11 +1522,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Last_Element (Container : Set) return Element_Type is begin - if Container.Tree.Last = null then + if Checks and then Container.Tree.Last = null then raise Constraint_Error with "set is empty"; - else - return Container.Tree.Last.Element.all; end if; + + return Container.Tree.Last.Element.all; end Last_Element; ---------- @@ -1654,7 +1573,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -1678,7 +1597,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1719,7 +1638,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -1744,7 +1663,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong set"; end if; @@ -1752,6 +1671,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1761,11 +1695,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -1774,25 +1708,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element.all); end; end Query_Element; @@ -1864,14 +1782,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is pragma Warnings (Off, X); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.Tree.TC); declare -- The element allocator may need an accessibility check in the case @@ -1941,12 +1856,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is X : Element_Access := Node.Element; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - -- Start of processing for Replace_Element begin @@ -1964,33 +1873,19 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Determine whether Item is equivalent to element on the specified -- node. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := (if Item < Node.Element.all then False elsif Node.Element.all < Item then False else True); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then -- Item is equivalent to the node's element, so we will not have to -- move the node. - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); declare -- The element allocator may need an accessibility check in the @@ -2019,26 +1914,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Hint := Element_Keys.Ceiling (Tree, Item); if Hint /= null then + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Item < Hint.Element.all; - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; -- Item >= Hint.Element - if not Compare then + if Checks and then not Compare then -- Ceiling returns an element that is equivalent or greater -- than Item. If Item is "not less than" the element, then @@ -2069,10 +1953,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- because it would only be placed in the exact same position. if Hint = Node then - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); declare -- The element allocator may need an accessibility check in the @@ -2118,15 +1999,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -2160,22 +2042,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index c885b80478e..e0e95ede1b3 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +private with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; @@ -298,17 +299,16 @@ package Ada.Containers.Indefinite_Ordered_Sets is type Key_Access is access all Key_Type; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Pos : Cursor; Old_Key : Key_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); @@ -338,7 +338,7 @@ private type Node_Type; type Node_Access is access Node_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record Parent : Node_Access; @@ -361,7 +361,7 @@ private overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -397,16 +397,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Set_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -430,13 +422,23 @@ private for Constant_Reference_Type'Write use Write; - Empty_Set : constant Set := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -445,7 +447,8 @@ private record Container : Set_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index 80437de5e0a..4db39237e6c 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +35,10 @@ package body Ada.Containers.Bounded_Vectors is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -89,7 +93,7 @@ package body Ada.Containers.Bounded_Vectors is -- we must check the sum of the combined lengths. Note that we cannot -- simply add the lengths, because of the possibility of overflow. - if LN > Count_Type'Last - RN then + if Checks and then LN > Count_Type'Last - RN then raise Constraint_Error with "new length is out of range"; end if; @@ -115,7 +119,9 @@ package body Ada.Containers.Bounded_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (N) < No_Index + then raise Constraint_Error with "new length is out of range"; end if; @@ -127,7 +133,7 @@ package body Ada.Containers.Bounded_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -139,7 +145,7 @@ package body Ada.Containers.Bounded_Vectors is J := Count_Type'Base (No_Index) + N; -- Last - if J > Count_Type'Base (Index_Type'Last) then + if Checks and then J > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; @@ -156,7 +162,7 @@ package body Ada.Containers.Bounded_Vectors is J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - if J < Count_Type'Base (No_Index) then + if Checks and then J < Count_Type'Base (No_Index) then raise Constraint_Error with "new length is out of range"; end if; @@ -193,11 +199,11 @@ package body Ada.Containers.Bounded_Vectors is -- constraints: the new length cannot exceed Count_Type'Last, and the -- new Last index cannot exceed Index_Type'Last. - if LN = Count_Type'Last then + if Checks and then LN = Count_Type'Last then raise Constraint_Error with "new length is out of range"; end if; - if Left.Last >= Index_Type'Last then + if Checks and then Left.Last >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -221,11 +227,11 @@ package body Ada.Containers.Bounded_Vectors is -- the new length cannot exceed Count_Type'Last, and the new Last index -- cannot exceed Index_Type'Last. - if RN = Count_Type'Last then + if Checks and then RN = Count_Type'Last then raise Constraint_Error with "new length is out of range"; end if; - if Right.Last >= Index_Type'Last then + if Checks and then Right.Last >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -248,7 +254,7 @@ package body Ada.Containers.Bounded_Vectors is -- know that that condition is satisfied), and the new Last index cannot -- exceed Index_Type'Last. - if Index_Type'First >= Index_Type'Last then + if Checks and then Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -263,78 +269,26 @@ package body Ada.Containers.Bounded_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - Result : Boolean; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Last /= Right.Last then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - Result := True; for J in Count_Type range 1 .. Left.Length loop if Left.Elements (J) /= Right.Elements (J) then - Result := False; - exit; + return False; end if; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + return True; end "="; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector 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; - - ------------ -- Assign -- ------------ @@ -344,7 +298,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error -- ??? with "Target capacity is less than Source length"; end if; @@ -367,7 +321,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Container.Last >= Index_Type'Last then + if Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -384,7 +338,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Container.Last >= Index_Type'Last then + if Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -406,10 +360,7 @@ package body Ada.Containers.Bounded_Vectors is procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); Container.Last := No_Index; end Clear; @@ -423,30 +374,30 @@ package body Ada.Containers.Bounded_Vectors is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Index > Position.Container.Last then + if Checks and then Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; declare A : Elements_Array renames Container.Elements; - I : constant Count_Type := To_Array_Index (Position.Index); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; + J : constant Count_Type := To_Array_Index (Position.Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => A (I)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => A (J)'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -456,20 +407,21 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type) return Constant_Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; declare A : Elements_Array renames Container.Elements; - I : constant Count_Type := To_Array_Index (Index); + J : constant Count_Type := To_Array_Index (Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => A (I)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => A (J)'Access, + Control => (Controlled with TC)) do - R.Control.Container.Busy := R.Control.Container.Busy + 1; - R.Control.Container.Lock := R.Control.Container.Lock + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -503,7 +455,7 @@ package body Ada.Containers.Bounded_Vectors is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -549,7 +501,7 @@ package body Ada.Containers.Bounded_Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Index < Index_Type'First then + if Checks and then Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; @@ -561,7 +513,7 @@ package body Ada.Containers.Bounded_Vectors is -- algorithm, so that case is treated as a proper error.) if Index > Old_Last then - if Index > Old_Last + 1 then + if Checks and then Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; @@ -581,10 +533,7 @@ package body Ada.Containers.Bounded_Vectors is -- the count on exit. Delete checks the count to determine whether it is -- being called while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We first calculate what's available for deletion starting at -- Index. Here and elsewhere we use the wider of Index_Type'Base and @@ -641,15 +590,16 @@ package body Ada.Containers.Bounded_Vectors is pragma Warnings (Off, Position); begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Index > Container.Last then + if Checks and then Position.Index > Container.Last then raise Program_Error with "Position index is out of range"; end if; @@ -703,10 +653,7 @@ package body Ada.Containers.Bounded_Vectors is -- it is being called while the associated callback procedure is -- executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- There is no restriction on how large Count can be when deleting -- items. If it is equal or greater than the current length, then this @@ -739,7 +686,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type) return Element_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; else return Container.Elements (To_Array_Index (Index)); @@ -748,7 +695,7 @@ package body Ada.Containers.Bounded_Vectors is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; else return Position.Container.Element (Position.Index); @@ -760,25 +707,8 @@ package body Ada.Containers.Bounded_Vectors is -------------- procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector 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; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -792,11 +722,12 @@ package body Ada.Containers.Bounded_Vectors is is begin if Position.Container /= null then - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Index > Container.Last then + if Checks and then Position.Index > Container.Last then raise Program_Error with "Position index is out of range"; end if; end if; @@ -805,38 +736,15 @@ package body Ada.Containers.Bounded_Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for J in Position.Index .. Container.Last loop if Container.Elements (To_Array_Index (J)) = Item then - Result := J; - exit; + return Cursor'(Container'Unrestricted_Access, J); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Find; @@ -849,37 +757,18 @@ package body Ada.Containers.Bounded_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; - - Result := No_Index; + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin for Indx in Index .. Container.Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Find_Index; ----------- @@ -924,11 +813,11 @@ package body Ada.Containers.Bounded_Vectors is function First_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; - else - return Container.Elements (To_Array_Index (Index_Type'First)); end if; + + return Container.Elements (To_Array_Index (Index_Type'First)); end First_Element; ----------------- @@ -961,36 +850,16 @@ package body Ada.Containers.Bounded_Vectors is -- element tampering by a generic actual subprogram. declare + Lock : With_Lock (Container.TC'Unrestricted_Access); EA : Elements_Array renames Container.Elements; - - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Boolean; - begin - B := B + 1; - L := L + 1; - - Result := True; for J in 1 .. Container.Length - 1 loop if EA (J + 1) < EA (J) then - Result := False; - exit; + return False; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return True; end; end Is_Sorted; @@ -1014,7 +883,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; @@ -1024,10 +893,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Source.TC); I := Target.Length; Target.Set_Length (I + Source.Length); @@ -1039,19 +905,9 @@ package body Ada.Containers.Bounded_Vectors is TA : Elements_Array renames Target.Elements; SA : Elements_Array renames Source.Elements; - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; - + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - J := Target.Length; while not Source.Is_Empty loop pragma Assert (Source.Length <= 1 @@ -1077,22 +933,6 @@ package body Ada.Containers.Bounded_Vectors is J := J - 1; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -1124,38 +964,31 @@ package body Ada.Containers.Bounded_Vectors is -- an artifact of our array-based implementation. Logically Sort -- requires a check for cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Container.Elements (1 .. Container.Length)); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; end Sort; end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements + (To_Array_Index (Position.Index))'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1199,7 +1032,7 @@ package body Ada.Containers.Bounded_Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Before < Index_Type'First then + if Checks and then Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; @@ -1211,7 +1044,7 @@ package body Ada.Containers.Bounded_Vectors is -- deeper flaw in the caller's algorithm, so that case is treated as a -- proper error.) - if Before > Container.Last + if Checks and then Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with @@ -1231,7 +1064,7 @@ package body Ada.Containers.Bounded_Vectors is -- count. Note that we cannot simply add these values, because of the -- possibility of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -1340,7 +1173,7 @@ package body Ada.Containers.Bounded_Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -1350,12 +1183,9 @@ package body Ada.Containers.Bounded_Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); - if New_Length > Container.Capacity then + if Checks and then New_Length > Container.Capacity then raise Capacity_Error with "New length is larger than capacity"; end if; @@ -1462,7 +1292,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1475,7 +1305,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1498,7 +1328,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1519,7 +1349,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1544,7 +1374,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1557,7 +1387,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1581,7 +1411,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1602,7 +1432,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1672,7 +1502,7 @@ package body Ada.Containers.Bounded_Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Before < Index_Type'First then + if Checks and then Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; @@ -1684,7 +1514,7 @@ package body Ada.Containers.Bounded_Vectors is -- deeper flaw in the caller's algorithm, so that case is treated as a -- proper error.) - if Before > Container.Last + if Checks and then Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with @@ -1704,7 +1534,7 @@ package body Ada.Containers.Bounded_Vectors is -- Note that we cannot simply add these values, because of the -- possibility of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -1813,7 +1643,7 @@ package body Ada.Containers.Bounded_Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -1823,15 +1653,12 @@ package body Ada.Containers.Bounded_Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- An internal array has already been allocated, so we need to check -- whether there is enough unused storage for the new items. - if New_Length > Container.Capacity then + if Checks and then New_Length > Container.Capacity then raise Capacity_Error with "New length is larger than capacity"; end if; @@ -1870,7 +1697,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1891,7 +1718,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1924,22 +1751,11 @@ package body Ada.Containers.Bounded_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Iterate; function Iterate @@ -1947,8 +1763,6 @@ package body Ada.Containers.Bounded_Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- The value of its Index component influences the behavior of the First -- and Last selector functions of the iterator object. When the Index @@ -1965,7 +1779,7 @@ package body Ada.Containers.Bounded_Vectors is Container => V, Index => No_Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1975,8 +1789,6 @@ package body Ada.Containers.Bounded_Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1989,17 +1801,17 @@ package body Ada.Containers.Bounded_Vectors is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start.Container = null then + if Checks and then Start.Container = null then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= V then + if Checks and then Start.Container /= V then raise Program_Error with "Start cursor of Iterate designates wrong vector"; end if; - if Start.Index > V.Last then + if Checks and then Start.Index > V.Last then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; @@ -2018,7 +1830,7 @@ package body Ada.Containers.Bounded_Vectors is Container => V, Index => Start.Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2063,11 +1875,11 @@ package body Ada.Containers.Bounded_Vectors is function Last_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; - else - return Container.Elements (Container.Length); end if; + + return Container.Elements (Container.Length); end Last_Element; ---------------- @@ -2126,20 +1938,13 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error -- ??? with "Target capacity is less than Source length"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Target is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Source is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- Clear Target now, in case element assignment fails @@ -2171,12 +1976,14 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; - else - return Next (Position); end if; + + return Next (Position); end Next; procedure Next (Position : in out Cursor) is @@ -2241,14 +2048,30 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; - else - return Previous (Position); end if; + + return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -2258,29 +2081,14 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type; Process : not null access procedure (Element : Element_Type)) is + Lock : With_Lock (Container.TC'Unrestricted_Access); V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; - begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (V.Elements (To_Array_Index (Index))); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (V.Elements (To_Array_Index (Index))); end Query_Element; procedure Query_Element @@ -2288,11 +2096,11 @@ package body Ada.Containers.Bounded_Vectors is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - else - Query_Element (Position.Container.all, Position.Index, Process); end if; + + Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -2353,28 +2161,31 @@ package body Ada.Containers.Bounded_Vectors is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Index > Position.Container.Last then + if Checks and then Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; declare A : Elements_Array renames Container.Elements; - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; J : constant Count_Type := To_Array_Index (Position.Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin - B := B + 1; - L := L + 1; - return (Element => A (J)'Access, - Control => (Controlled with Container'Unrestricted_Access)); + return R : constant Reference_Type := + (Element => A (J)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; end; end Reference; @@ -2383,20 +2194,22 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type) return Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; declare A : Elements_Array renames Container.Elements; - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; J : constant Count_Type := To_Array_Index (Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin - B := B + 1; - L := L + 1; - return (Element => A (J)'Access, - Control => (Controlled with Container'Unrestricted_Access)); + return R : constant Reference_Type := + (Element => A (J)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; end; end Reference; @@ -2410,14 +2223,13 @@ package body Ada.Containers.Bounded_Vectors is New_Item : Element_Type) is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - else - Container.Elements (To_Array_Index (Index)) := New_Item; end if; + + TE_Check (Container.TC); + + Container.Elements (To_Array_Index (Index)) := New_Item; end Replace_Element; procedure Replace_Element @@ -2426,22 +2238,22 @@ package body Ada.Containers.Bounded_Vectors is New_Item : Element_Type) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; + end if; - elsif Position.Index > Container.Last then + if Checks and then Position.Index > Container.Last then raise Constraint_Error with "Position cursor is out of range"; + end if; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; + TE_Check (Container.TC); - else - Container.Elements (To_Array_Index (Position.Index)) := New_Item; - end if; + Container.Elements (To_Array_Index (Position.Index)) := New_Item; end Replace_Element; ---------------------- @@ -2453,7 +2265,7 @@ package body Ada.Containers.Bounded_Vectors is Capacity : Count_Type) is begin - if Capacity > Container.Capacity then + if Checks and then Capacity > Container.Capacity then raise Capacity_Error with "Capacity is out of range"; end if; end Reserve_Capacity; @@ -2483,10 +2295,7 @@ package body Ada.Containers.Bounded_Vectors is -- implementation. Logically Reverse_Elements requires a check for -- cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); Idx := 1; Jdx := Container.Length; @@ -2516,7 +2325,7 @@ package body Ada.Containers.Bounded_Vectors is Last : Index_Type'Base; begin - if Position.Container /= null + if Checks and then Position.Container /= null and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; @@ -2531,38 +2340,15 @@ package body Ada.Containers.Bounded_Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - Result := Indx; - exit; + return Cursor'(Container'Unrestricted_Access, Indx); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Reverse_Find; @@ -2575,40 +2361,22 @@ package body Ada.Containers.Bounded_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); Last : constant Index_Type'Base := Index_Type'Min (Container.Last, Index); - Result : Index_Type'Base; - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Reverse_Find_Index; --------------------- @@ -2619,23 +2387,11 @@ package body Ada.Containers.Bounded_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Reverse_Iterate; ---------------- @@ -2655,11 +2411,13 @@ package body Ada.Containers.Bounded_Vectors is if Count >= 0 then Container.Delete_Last (Count); - elsif Container.Last >= Index_Type'Last then + end if; + + if Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; - else - Container.Insert_Space (Container.Last + 1, -Count); end if; + + Container.Insert_Space (Container.Last + 1, -Count); end Set_Length; ---------- @@ -2670,11 +2428,11 @@ package body Ada.Containers.Bounded_Vectors is E : Elements_Array renames Container.Elements; begin - if I > Container.Last then + if Checks and then I > Container.Last then raise Constraint_Error with "I index is out of range"; end if; - if J > Container.Last then + if Checks and then J > Container.Last then raise Constraint_Error with "J index is out of range"; end if; @@ -2682,10 +2440,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + TE_Check (Container.TC); declare EI_Copy : constant Element_Type := E (To_Array_Index (I)); @@ -2697,19 +2452,19 @@ package body Ada.Containers.Bounded_Vectors is procedure Swap (Container : in out Vector; I, J : Cursor) is begin - if I.Container = null then + if Checks and then I.Container = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Container = null then + if Checks and then J.Container = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor denotes wrong container"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor denotes wrong container"; end if; @@ -2814,7 +2569,9 @@ package body Ada.Containers.Bounded_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -2826,7 +2583,7 @@ package body Ada.Containers.Bounded_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -2838,7 +2595,7 @@ package body Ada.Containers.Bounded_Vectors is Index := Count_Type'Base (No_Index) + Length; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -2855,7 +2612,7 @@ package body Ada.Containers.Bounded_Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -2903,7 +2660,9 @@ package body Ada.Containers.Bounded_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -2915,7 +2674,7 @@ package body Ada.Containers.Bounded_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -2927,7 +2686,7 @@ package body Ada.Containers.Bounded_Vectors is Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -2944,7 +2703,7 @@ package body Ada.Containers.Bounded_Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -2970,28 +2729,13 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (Container.Elements (To_Array_Index (Index))); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Container.Elements (To_Array_Index (Index))); end Update_Element; procedure Update_Element @@ -3000,11 +2744,12 @@ package body Ada.Containers.Bounded_Vectors is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads index 3bd1843d7b3..1fb346c7972 100644 --- a/gcc/ada/a-cobove.ads +++ b/gcc/ada/a-cobove.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +private with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; @@ -364,6 +365,10 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + use Ada.Streams; use Ada.Finalization; @@ -373,8 +378,7 @@ private type Vector (Capacity : Count_Type) is tagged record Elements : Elements_Array (1 .. Capacity) := (others => <>); Last : Extended_Index := No_Index; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; procedure Write @@ -409,15 +413,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is new Controlled with record - Container : Vector_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -461,6 +458,25 @@ private for Reference_Type'Write use Write; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Vector : constant Vector := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(null, Index_Type'First); @@ -470,7 +486,8 @@ private record Container : Vector_Access; Index : Index_Type'Base; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 6fe9bfd576b..969bf9be122 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -35,12 +35,18 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with System; use type System.Address; package body Ada.Containers.Hashed_Maps is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -123,20 +129,6 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Adjust (Container.HT); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -199,12 +191,13 @@ package body Ada.Containers.Hashed_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -215,15 +208,14 @@ package body Ada.Containers.Hashed_Maps is declare HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -236,20 +228,19 @@ package body Ada.Containers.Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -280,7 +271,7 @@ package body Ada.Containers.Hashed_Maps is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -316,7 +307,7 @@ package body Ada.Containers.Hashed_Maps is begin Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in map"; end if; @@ -325,20 +316,18 @@ package body Ada.Containers.Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; - if Container.HT.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with cursors (map is busy)"; - end if; + TC_Check (Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -357,7 +346,7 @@ package body Ada.Containers.Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "no element available because key not in map"; end if; @@ -367,7 +356,7 @@ package body Ada.Containers.Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; @@ -395,12 +384,12 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; @@ -413,7 +402,7 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; @@ -425,7 +414,7 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; @@ -458,27 +447,7 @@ package body Ada.Containers.Hashed_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.HT.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.HT.TC); end if; end Finalize; @@ -600,10 +569,7 @@ package body Ada.Containers.Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.HT.TC); Position.Node.Key := Key; Position.Node.Element := New_Item; @@ -712,7 +678,7 @@ package body Ada.Containers.Hashed_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert key already in map"; end if; @@ -749,33 +715,22 @@ package body Ada.Containers.Hashed_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container.HT); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; begin return It : constant Iterator := (Limited_Controlled with Container => Container'Unrestricted_Access) do - B := B + 1; + Busy (Container.HT.TC'Unrestricted_Access.all); end return; end Iterate; @@ -785,7 +740,7 @@ package body Ada.Containers.Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; @@ -860,7 +815,7 @@ package body Ada.Containers.Hashed_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -875,15 +830,11 @@ package body Ada.Containers.Hashed_Maps is function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type is - C : constant Map_Access := Container'Unrestricted_Access; - B : Natural renames C.HT.Busy; - L : Natural renames C.HT.Lock; + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -897,7 +848,7 @@ package body Ada.Containers.Hashed_Maps is procedure (Key : Key_Type; Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -907,28 +858,11 @@ package body Ada.Containers.Hashed_Maps is declare M : Map renames Position.Container.all; HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Query_Element; @@ -977,12 +911,13 @@ package body Ada.Containers.Hashed_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -993,15 +928,14 @@ package body Ada.Containers.Hashed_Maps is declare HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1014,20 +948,19 @@ package body Ada.Containers.Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1064,15 +997,12 @@ package body Ada.Containers.Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in map"; end if; - if Container.HT.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.HT.TC); Node.Key := Key; Node.Element := New_Item; @@ -1088,20 +1018,18 @@ package body Ada.Containers.Hashed_Maps is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Position.Container.HT.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Position.Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -1140,12 +1068,13 @@ package body Ada.Containers.Hashed_Maps is Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1154,27 +1083,11 @@ package body Ada.Containers.Hashed_Maps is declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Update_Element; diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 12c352962de..c398812db76 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -337,7 +337,7 @@ private overriding procedure Finalize (Container : in out Map); - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -373,16 +373,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : Map_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -440,13 +432,14 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); + Empty_Map : constant Map := (Controlled with others => <>); No_Element : constant Cursor := (Container => null, Node => null); @@ -454,7 +447,8 @@ private Map_Iterator_Interfaces.Forward_Iterator with record Container : Map_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 1ce5c4a50b9..125f6b0f483 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -35,6 +35,8 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Prime_Numbers; with System; use type System.Address; @@ -43,6 +45,10 @@ package body Ada.Containers.Hashed_Sets is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -152,20 +158,6 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -212,11 +204,12 @@ package body Ada.Containers.Hashed_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -225,15 +218,14 @@ package body Ada.Containers.Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -264,7 +256,7 @@ package body Ada.Containers.Hashed_Sets is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -297,7 +289,7 @@ package body Ada.Containers.Hashed_Sets is begin Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -309,18 +301,16 @@ package body Ada.Containers.Hashed_Sets is Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if Container.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -351,10 +341,7 @@ package body Ada.Containers.Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); if Src_HT.Length < Target.HT.Length then declare @@ -462,7 +449,7 @@ package body Ada.Containers.Hashed_Sets is raise; end Iterate_Left; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Difference; ------------- @@ -471,7 +458,7 @@ package body Ada.Containers.Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -496,12 +483,12 @@ package body Ada.Containers.Hashed_Sets is function Equivalent_Elements (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; @@ -529,7 +516,7 @@ package body Ada.Containers.Hashed_Sets is function Equivalent_Elements (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; @@ -542,7 +529,7 @@ package body Ada.Containers.Hashed_Sets is function Equivalent_Elements (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; @@ -587,30 +574,10 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Finalize (Container.HT); end Finalize; - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; - end Finalize; - procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.HT.Busy; - begin - B := B - 1; - end; + Unbusy (Object.Container.HT.TC); end if; end Finalize; @@ -766,10 +733,7 @@ package body Ada.Containers.Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.HT.TC); Position.Node.Element := New_Item; end if; @@ -802,7 +766,7 @@ package body Ada.Containers.Hashed_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -836,10 +800,7 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Reserve_Capacity (HT, 1); end if; - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (HT.TC); Local_Insert (HT, New_Item, Node, Inserted); @@ -871,10 +832,7 @@ package body Ada.Containers.Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop @@ -960,7 +918,7 @@ package body Ada.Containers.Hashed_Sets is raise; end Iterate_Left; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Intersection; -------------- @@ -1036,30 +994,19 @@ package body Ada.Containers.Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Iterate (Container.HT); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; begin - B := B + 1; + Busy (Container.HT.TC'Unrestricted_Access.all); return It : constant Iterator := Iterator'(Limited_Controlled with Container => Container'Unrestricted_Access); @@ -1127,7 +1074,7 @@ package body Ada.Containers.Hashed_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1171,15 +1118,11 @@ package body Ada.Containers.Hashed_Sets is function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type is - C : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames C.HT.Busy; - L : Natural renames C.HT.Lock; - begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -1192,7 +1135,7 @@ package body Ada.Containers.Hashed_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -1201,25 +1144,9 @@ package body Ada.Containers.Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.HT; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element); end; end Query_Element; @@ -1280,15 +1207,12 @@ package body Ada.Containers.Hashed_Sets is Element_Keys.Find (Container.HT, New_Item); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.HT.TC); Node.Element := New_Item; end Replace; @@ -1299,12 +1223,13 @@ package body Ada.Containers.Hashed_Sets is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1345,26 +1270,13 @@ package body Ada.Containers.Hashed_Sets is is Tgt_HT : Hash_Table_Type renames Target.HT; Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - TB : Natural renames Tgt_HT.Busy; - TL : Natural renames Tgt_HT.Lock; - - SB : Natural renames Src_HT.Busy; - SL : Natural renames Src_HT.Lock; - begin if Target'Address = Source'Address then Clear (Target); return; end if; - if TB > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Tgt_HT.TC); declare N : constant Count_Type := Target.Length + Source.Length; @@ -1378,8 +1290,7 @@ package body Ada.Containers.Hashed_Sets is Iterate_Source_When_Empty_Target : declare procedure Process (Src_Node : Node_Access); - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + procedure Iterate is new HT_Ops.Generic_Iteration (Process); ------------- -- Process -- @@ -1396,32 +1307,16 @@ package body Ada.Containers.Hashed_Sets is N := N + 1; end Process; - -- Start of processing for Iterate_Source_When_Empty_Target + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. - begin - TB := TB + 1; - TL := TL + 1; + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - SB := SB + 1; - SL := SL + 1; + -- Start of processing for Iterate_Source_When_Empty_Target + begin Iterate (Src_HT); - - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - exception - when others => - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - raise; end Iterate_Source_When_Empty_Target; else @@ -1479,32 +1374,16 @@ package body Ada.Containers.Hashed_Sets is end if; end Process; - -- Start of processing for Iterate_Source + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. - begin - TB := TB + 1; - TL := TL + 1; + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - SB := SB + 1; - SL := SL + 1; + -- Start of processing for Iterate_Source + begin Iterate (Src_HT); - - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - exception - when others => - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - raise; end Iterate_Source; end if; end Symmetric_Difference; @@ -1621,7 +1500,7 @@ package body Ada.Containers.Hashed_Sets is raise; end Iterate_Right; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Symmetric_Difference; ------------ @@ -1692,10 +1571,7 @@ package body Ada.Containers.Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); declare N : constant Count_Type := Target.Length + Source.Length; @@ -1757,25 +1633,14 @@ package body Ada.Containers.Hashed_Sets is -- Checked_Index instead of a simple invocation of generic formal -- Hash. - B : Integer renames Left_HT.Busy; - L : Integer renames Left_HT.Lock; + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); -- Start of processing for Iterate_Left begin - B := B + 1; - L := L + 1; - Iterate (Left_HT); - - L := L - 1; - B := B - 1; - exception when others => - L := L - 1; - B := B - 1; - HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Left; @@ -1816,42 +1681,20 @@ package body Ada.Containers.Hashed_Sets is -- Checked_Index instead of a simple invocation of generic formal -- Hash. - LB : Integer renames Left_HT.Busy; - LL : Integer renames Left_HT.Lock; - - RB : Integer renames Right_HT.Busy; - RL : Integer renames Right_HT.Lock; + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); -- Start of processing for Iterate_Right begin - LB := LB + 1; - LL := LL + 1; - - RB := RB + 1; - RL := RL + 1; - Iterate (Right_HT); - - RL := RL - 1; - RB := RB - 1; - - LL := LL - 1; - LB := LB - 1; - exception when others => - RL := RL - 1; - RB := RB - 1; - - LL := LL - 1; - LB := LB - 1; - HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Right; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Union; --------- @@ -1957,24 +1800,6 @@ package body Ada.Containers.Hashed_Sets is -- Local Subprograms -- ----------------------- - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean; @@ -2005,20 +1830,19 @@ package body Ada.Containers.Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -2048,7 +1872,7 @@ package body Ada.Containers.Hashed_Sets is begin Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -2067,7 +1891,7 @@ package body Ada.Containers.Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; @@ -2107,16 +1931,10 @@ package body Ada.Containers.Hashed_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; + Impl.Reference_Control_Type (Control).Finalize; - if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + if Checks and then + Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash then HT_Ops.Delete_Node_At_Index (Control.Container.HT, Control.Index, Control.Old_Pos.Node); @@ -2151,7 +1969,7 @@ package body Ada.Containers.Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -2182,11 +2000,12 @@ package body Ada.Containers.Hashed_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -2197,20 +2016,18 @@ package body Ada.Containers.Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, Control => (Controlled with + HT.TC'Unrestricted_Access, Container'Unrestricted_Access, Index => HT_Ops.Index (HT, Position.Node), Old_Pos => Position, Old_Hash => Hash (Key (Position)))) do - B := B + 1; - L := L + 1; + Lock (HT.TC); end return; end; end Reference_Preserving_Key; @@ -2222,27 +2039,25 @@ package body Ada.Containers.Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; P : constant Cursor := Find (Container, Key); begin return R : constant Reference_Type := (Element => Node.Element'Access, Control => (Controlled with + HT.TC'Unrestricted_Access, Container'Unrestricted_Access, Index => HT_Ops.Index (HT, P.Node), Old_Pos => P, Old_Hash => Hash (Key))) do - B := B + 1; - L := L + 1; + Lock (HT.TC); end return; end; end Reference_Preserving_Key; @@ -2259,7 +2074,7 @@ package body Ada.Containers.Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -2281,20 +2096,22 @@ package body Ada.Containers.Hashed_Sets is Indx : Hash_Type; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if HT.Buckets = null - or else HT.Buckets'Length = 0 - or else HT.Length = 0 - or else Position.Node.Next = Position.Node + if Checks and then + (HT.Buckets = null + or else HT.Buckets'Length = 0 + or else HT.Length = 0 + or else Position.Node.Next = Position.Node) then raise Program_Error with "Position cursor is bad (set is empty)"; end if; @@ -2309,31 +2126,12 @@ package body Ada.Containers.Hashed_Sets is declare E : Element_Type renames Position.Node.Element; K : constant Key_Type := Key (E); - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - - Eq : Boolean; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Indx := HT_Ops.Index (HT, Position.Node); - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Indx := HT_Ops.Index (HT, Position.Node); + Process (E); - if Eq then + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -2349,7 +2147,7 @@ package body Ada.Containers.Hashed_Sets is while Prev.Next /= Position.Node loop Prev := Prev.Next; - if Prev = null then + if Checks and then Prev = null then raise Program_Error with "Position cursor is bad (node not found)"; end if; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 7e5671edfb4..91f13453943 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -34,6 +34,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; +private with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -451,8 +452,10 @@ package Ada.Containers.Hashed_Sets is -- in that case the check that buckets have not changed is performed -- at the time of the update, not when the reference is finalized. + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Index : Hash_Type; @@ -460,9 +463,6 @@ package Ada.Containers.Hashed_Sets is 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); @@ -505,7 +505,7 @@ private overriding procedure Finalize (Container : in out Set); - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -529,10 +529,6 @@ private Node : Node_Access; end record; - type Reference_Control_Type is new Ada.Finalization.Controlled with record - Container : Set_Access; - end record; - procedure Write (Stream : not null access Root_Stream_Type'Class; Item : Cursor); @@ -545,11 +541,8 @@ private for Cursor'Read use Read; - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -585,21 +578,23 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0)); + Empty_Set : constant Set := (Controlled with others => <>); No_Element : constant Cursor := (Container => null, Node => null); - type Iterator is new Limited_Controlled - and Set_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with record Container : Set_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding function First (Object : Iterator) return Cursor; diff --git a/gcc/ada/a-cohata.ads b/gcc/ada/a-cohata.ads index 1a77970a0c7..c83e8c0081c 100644 --- a/gcc/ada/a-cohata.ads +++ b/gcc/ada/a-cohata.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,6 +30,8 @@ -- This package declares the hash-table type used to implement hashed -- containers. +with Ada.Containers.Helpers; + package Ada.Containers.Hash_Tables is pragma Pure; -- Declare Pure so this can be imported by Remote_Types packages @@ -40,6 +42,7 @@ package Ada.Containers.Hash_Tables is type Node_Access is access Node_Type; package Generic_Hash_Table_Types is + type Buckets_Type is array (Hash_Type range <>) of Node_Access; type Buckets_Access is access all Buckets_Type; @@ -47,16 +50,18 @@ package Ada.Containers.Hash_Tables is -- Storage_Size of zero so this package can be Pure type Hash_Table_Type is tagged record - Buckets : Buckets_Access; + Buckets : Buckets_Access := null; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Helpers.Tamper_Counts; end record; + + package Implementation is new Helpers.Generic_Implementation; end Generic_Hash_Table_Types; generic type Node_Type is private; package Generic_Bounded_Hash_Table_Types is + type Nodes_Type is array (Count_Type range <>) of Node_Type; type Buckets_Type is array (Hash_Type range <>) of Count_Type; @@ -65,12 +70,13 @@ package Ada.Containers.Hash_Tables is Modulus : Hash_Type) is tagged record Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Helpers.Tamper_Counts; Free : Count_Type'Base := -1; Nodes : Nodes_Type (1 .. Capacity) := (others => <>); Buckets : Buckets_Type (1 .. Modulus) := (others => 0); end record; + + package Implementation is new Helpers.Generic_Implementation; end Generic_Bounded_Hash_Table_Types; end Ada.Containers.Hash_Tables; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 0f8d04085e4..106178a02bf 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -38,7 +38,7 @@ package body Ada.Containers.Indefinite_Vectors is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers + -- See comment in Ada.Containers.Helpers procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -304,25 +304,19 @@ package body Ada.Containers.Indefinite_Vectors is end if; end if; - if T_Check then - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - -- The following will raise Constraint_Error if Element is null - - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Position.Index), - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - else + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + -- The following will raise Constraint_Error if Element is null + return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Position.Index), - Control => (Controlled with null)); - end if; + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; function Constant_Reference @@ -334,25 +328,19 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error with "Index is out of range"; end if; - if T_Check then - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - -- The following will raise Constraint_Error if Element is null - - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Index), - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - else + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + -- The following will raise Constraint_Error if Element is null + return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Index), - Control => (Controlled with null)); - end if; + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; -------------- @@ -2700,25 +2688,19 @@ package body Ada.Containers.Indefinite_Vectors is end if; end if; - if T_Check then - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - -- The following will raise Constraint_Error if Element is null - - return R : constant Reference_Type := - (Element => Container.Elements.EA (Position.Index), - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - else + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + -- The following will raise Constraint_Error if Element is null + return R : constant Reference_Type := (Element => Container.Elements.EA (Position.Index), - Control => (Controlled with null)); - end if; + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; function Reference @@ -2730,25 +2712,19 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error with "Index is out of range"; end if; - if T_Check then - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - -- The following will raise Constraint_Error if Element is null - - return R : constant Reference_Type := - (Element => Container.Elements.EA (Index), - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - else + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + -- The following will raise Constraint_Error if Element is null + return R : constant Reference_Type := (Element => Container.Elements.EA (Index), - Control => (Controlled with null)); - end if; + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index 14d879e00ab..08aa4c9f5b4 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,6 +36,10 @@ package body Ada.Containers.Multiway_Trees is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + -------------------- -- Root_Iterator -- -------------------- @@ -166,10 +170,6 @@ package body Ada.Containers.Multiway_Trees is function "=" (Left, Right : Tree) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - return Equal_Children (Root_Node (Left), Root_Node (Right)); end "="; @@ -188,8 +188,7 @@ package body Ada.Containers.Multiway_Trees is -- are preserved in the event that the allocation fails. Container.Root.Children := Children_Type'(others => null); - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); Container.Count := 0; -- Copy_Children returns a count of the number of nodes that it @@ -208,20 +207,6 @@ package body Ada.Containers.Multiway_Trees is Container.Count := Source_Count; 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; - ------------------- -- Ancestor_Find -- ------------------- @@ -233,7 +218,7 @@ package body Ada.Containers.Multiway_Trees is R, N : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; @@ -247,7 +232,7 @@ package body Ada.Containers.Multiway_Trees is -- 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.??? - -- if Is_Root (Position) then + -- if Checks and then Is_Root (Position) then -- raise Program_Error with "Position cursor designates root"; -- end if; @@ -278,11 +263,11 @@ package body Ada.Containers.Multiway_Trees is Last : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -290,10 +275,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); First := new Tree_Node_Type'(Parent => Parent.Node, Element => New_Item, @@ -390,15 +372,15 @@ package body Ada.Containers.Multiway_Trees is N : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Child = No_Element then + if Checks and then Child = No_Element then raise Constraint_Error with "Child cursor has no element"; end if; - if Parent.Container /= Child.Container then + if Checks and then Parent.Container /= Child.Container then raise Program_Error with "Parent and Child in different containers"; end if; @@ -408,7 +390,7 @@ package body Ada.Containers.Multiway_Trees is Result := Result + 1; N := N.Parent; - if N = null then + if Checks and then N = null then raise Program_Error with "Parent is not ancestor of Child"; end if; end loop; @@ -424,10 +406,7 @@ package body Ada.Containers.Multiway_Trees is Container_Count, Children_Count : Count_Type; begin - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); -- We first set the container count to 0, in order to preserve -- invariants in case the deallocation fails. (This works because @@ -462,17 +441,18 @@ package body Ada.Containers.Multiway_Trees is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; @@ -482,15 +462,14 @@ package body Ada.Containers.Multiway_Trees is declare C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + C.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -594,20 +573,20 @@ package body Ada.Containers.Multiway_Trees is Target_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; @@ -616,7 +595,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Is_Root (Source) then + if Checks and then Is_Root (Source) then raise Constraint_Error with "Source cursor designates root"; end if; @@ -720,18 +699,15 @@ package body Ada.Containers.Multiway_Trees is Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); -- Deallocate_Children returns a count of the number of nodes that it -- deallocates, but it works by incrementing the value that is passed @@ -757,26 +733,24 @@ package body Ada.Containers.Multiway_Trees is X : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if not Is_Leaf (Position) then + if Checks and then not Is_Leaf (Position) then raise Constraint_Error with "Position cursor does not designate leaf"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -806,22 +780,20 @@ package body Ada.Containers.Multiway_Trees is Count : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -884,11 +856,12 @@ package body Ada.Containers.Multiway_Trees is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node = Root_Node (Position.Container.all) then + if Checks and then Position.Node = Root_Node (Position.Container.all) + then raise Program_Error with "Position cursor designates root"; end if; @@ -936,11 +909,11 @@ package body Ada.Containers.Multiway_Trees is Right_Position : Cursor) return Boolean is begin - if Left_Position = No_Element then + if Checks and then Left_Position = No_Element then raise Constraint_Error with "Left cursor has no element"; end if; - if Right_Position = No_Element then + if Checks and then Right_Position = No_Element then raise Constraint_Error with "Right cursor has no element"; end if; @@ -980,25 +953,8 @@ package body Ada.Containers.Multiway_Trees is -------------- procedure Finalize (Object : in out Root_Iterator) is - B : Natural renames Object.Container.Busy; begin - 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; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -1045,7 +1001,7 @@ package body Ada.Containers.Multiway_Trees is Node : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1103,13 +1059,15 @@ package body Ada.Containers.Multiway_Trees is Result : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Commented out pending official ruling by ARG. ??? - -- if Position.Container /= Container'Unrestricted_Access then + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then -- raise Program_Error with "Position cursor not in container"; -- end if; @@ -1137,6 +1095,16 @@ package body Ada.Containers.Multiway_Trees is return Find_In_Children (Subtree, Item); end Find_In_Subtree; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1177,20 +1145,21 @@ package body Ada.Containers.Multiway_Trees is Last : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1200,10 +1169,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); First := new Tree_Node_Type'(Parent => Parent.Node, Element => New_Item, @@ -1248,20 +1214,21 @@ package body Ada.Containers.Multiway_Trees is Last : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1271,10 +1238,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); First := new Tree_Node_Type'(Parent => Parent.Node, Element => <>, @@ -1441,22 +1405,12 @@ package body Ada.Containers.Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - Iterate_Children (Container => Container'Unrestricted_Access, Subtree => Root_Node (Container), Process => Process); - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end Iterate; function Iterate (Container : Tree) @@ -1474,31 +1428,18 @@ package body Ada.Containers.Multiway_Trees is (Parent : Cursor; Process : not null access procedure (Position : Cursor)) is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - declare - B : Natural renames Parent.Container.Busy; - C : Tree_Node_Access; - - begin - B := B + 1; - - C := Parent.Node.Children.First; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Next; - end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + C := Parent.Node.Children.First; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Next; + end loop; end Iterate_Children; procedure Iterate_Children @@ -1528,14 +1469,12 @@ package body Ada.Containers.Multiway_Trees is return Tree_Iterator_Interfaces.Reversible_Iterator'Class is C : constant Tree_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= C then + if Checks and then Parent.Container /= C then raise Program_Error with "Parent cursor not in container"; end if; @@ -1544,7 +1483,7 @@ package body Ada.Containers.Multiway_Trees is Container => C, Subtree => Parent.Node) do - B := B + 1; + Busy (C.TC); end return; end Iterate_Children; @@ -1556,55 +1495,39 @@ package body Ada.Containers.Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + C : constant Tree_Access := Position.Container; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Implement Vet for multiway trees??? -- pragma Assert (Vet (Position), "bad subtree cursor"); - declare - B : Natural renames Position.Container.Busy; - begin - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => Position.Container, - Subtree => Position.Node) - do - B := B + 1; - end return; - end; + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => C, + Subtree => Position.Node) + do + Busy (C.TC); + end return; end Iterate_Subtree; procedure Iterate_Subtree (Position : Cursor; Process : not null access procedure (Position : Cursor)) is + Busy : With_Busy (Position.Container.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - declare - B : Natural renames Position.Container.Busy; - - begin - B := B + 1; - - if Is_Root (Position) then - Iterate_Children (Position.Container, Position.Node, Process); - else - Iterate_Subtree (Position.Container, Position.Node, Process); - end if; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + if Is_Root (Position) then + Iterate_Children (Position.Container, Position.Node, Process); + else + Iterate_Subtree (Position.Container, Position.Node, Process); + end if; end Iterate_Subtree; procedure Iterate_Subtree @@ -1638,7 +1561,7 @@ package body Ada.Containers.Multiway_Trees is Node : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1672,10 +1595,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors of Source (tree is busy)"; - end if; + TC_Check (Source.TC); Target.Clear; -- checks busy bit @@ -1707,7 +1627,7 @@ package body Ada.Containers.Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -1738,7 +1658,7 @@ package body Ada.Containers.Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -1817,11 +1737,11 @@ package body Ada.Containers.Multiway_Trees is First, Last : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -1829,10 +1749,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); First := new Tree_Node_Type'(Parent => Parent.Node, Element => New_Item, @@ -1878,7 +1795,7 @@ package body Ada.Containers.Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong tree"; end if; @@ -1903,6 +1820,20 @@ package body Ada.Containers.Multiway_Trees is Position := Previous_Sibling (Position); end Previous_Sibling; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1911,36 +1842,18 @@ package body Ada.Containers.Multiway_Trees is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - - begin - B := B + 1; - L := L + 1; - - Process (Position.Node.Element); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; + Process (Position.Node.Element); end Query_Element; ---------- @@ -1979,7 +1892,7 @@ package body Ada.Containers.Multiway_Trees is begin Count_Type'Read (Stream, Count); - if Count < 0 then + if Checks and then Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2030,7 +1943,7 @@ package body Ada.Containers.Multiway_Trees is Count_Type'Read (Stream, Total_Count); - if Total_Count < 0 then + if Checks and then Total_Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2042,7 +1955,7 @@ package body Ada.Containers.Multiway_Trees is Read_Children (Root_Node (Container)); - if Read_Count /= Total_Count then + if Checks and then Read_Count /= Total_Count then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2082,17 +1995,18 @@ package body Ada.Containers.Multiway_Trees is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; @@ -2102,15 +2016,14 @@ package body Ada.Containers.Multiway_Trees is declare C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + C.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -2160,22 +2073,20 @@ package body Ada.Containers.Multiway_Trees is New_Item : Element_Type) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); Position.Node.Element := New_Item; end Replace_Element; @@ -2188,31 +2099,18 @@ package body Ada.Containers.Multiway_Trees is (Parent : Cursor; Process : not null access procedure (Position : Cursor)) is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - declare - B : Natural renames Parent.Container.Busy; - C : Tree_Node_Access; - - begin - B := B + 1; - - C := Parent.Node.Children.Last; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Prev; - end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + C := Parent.Node.Children.Last; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Prev; + end loop; end Reverse_Iterate_Children; ---------- @@ -2262,32 +2160,34 @@ package body Ada.Containers.Multiway_Trees is Count : Count_Type; begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Target'Unrestricted_Access then + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Before.Node.Parent /= Target_Parent.Node then + if Checks and then Before.Node.Parent /= Target_Parent.Node then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Source'Unrestricted_Access then + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in Source container"; end if; @@ -2297,12 +2197,9 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (From => Target_Parent.Node, + if Checks and then Is_Reachable (From => Target_Parent.Node, To => Source_Parent.Node) then raise Constraint_Error @@ -2317,15 +2214,8 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- We cache the count of the nodes we have allocated, so that operation -- Node_Count can execute in O(1) time. But that means we must count the @@ -2353,32 +2243,37 @@ package body Ada.Containers.Multiway_Trees is Source_Parent : Cursor) is begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Target_Parent.Node then + if Checks and then Before.Node.Parent /= Target_Parent.Node then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in container"; end if; @@ -2387,12 +2282,9 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (From => Target_Parent.Node, + if Checks and then Is_Reachable (From => Target_Parent.Node, To => Source_Parent.Node) then raise Constraint_Error @@ -2449,33 +2341,33 @@ package body Ada.Containers.Multiway_Trees is Subtree_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor not in Source container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; @@ -2490,12 +2382,11 @@ package body Ada.Containers.Multiway_Trees is end if; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (From => Parent.Node, To => Position.Node) then + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then raise Constraint_Error with "Position is ancestor of Parent"; end if; @@ -2507,15 +2398,8 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- This is an unfortunate feature of this API: we must count the nodes -- in the subtree that we remove from the source tree, which is an O(n) @@ -2549,33 +2433,35 @@ package body Ada.Containers.Multiway_Trees is Position : Cursor) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then -- Should this be PE instead? Need ARG confirmation. ??? @@ -2592,12 +2478,11 @@ package body Ada.Containers.Multiway_Trees is end if; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (From => Parent.Node, To => Position.Node) then + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then raise Constraint_Error with "Position is ancestor of Parent"; end if; @@ -2646,15 +2531,15 @@ package body Ada.Containers.Multiway_Trees is I, J : Cursor) is begin - if I = No_Element then + if Checks and then I = No_Element then raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor not in container"; end if; - if Is_Root (I) then + if Checks and then Is_Root (I) then raise Program_Error with "I cursor designates root"; end if; @@ -2662,22 +2547,19 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if J = No_Element then + if Checks and then J = No_Element then raise Constraint_Error with "J cursor has no element"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor not in container"; end if; - if Is_Root (J) then + if Checks and then Is_Root (J) then raise Program_Error with "J cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); declare EI : constant Element_Type := I.Node.Element; @@ -2697,40 +2579,23 @@ package body Ada.Containers.Multiway_Trees is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - - begin - B := B + 1; - L := L + 1; - - Process (Position.Node.Element); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; + Process (Position.Node.Element); end Update_Element; ----------- diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads index 3ea29452929..918edfdd8aa 100644 --- a/gcc/ada/a-comutr.ads +++ b/gcc/ada/a-comutr.ads @@ -32,6 +32,8 @@ ------------------------------------------------------------------------------ with Ada.Iterator_Interfaces; + +private with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -333,6 +335,10 @@ private -- thus guaranteeing that (unchecked) conversions between access types -- designating each kind of node type is a meaningful conversion. + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Tree_Node_Type; type Tree_Node_Access is access all Tree_Node_Type; pragma Convention (C, Tree_Node_Access); @@ -386,8 +392,7 @@ private type Tree is new Controlled with record Root : aliased Root_Node_Type; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; Count : Count_Type := 0; end record; @@ -429,16 +434,8 @@ private for Cursor'Read use Read; - 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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -484,6 +481,25 @@ private for Reference_Type'Write use Write; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Tree : constant Tree := (Controlled with others => <>); No_Element : constant Cursor := (others => <>); diff --git a/gcc/ada/a-conhel.adb b/gcc/ada/a-conhel.adb index 11fe035022a..f433250000a 100644 --- a/gcc/ada/a-conhel.adb +++ b/gcc/ada/a-conhel.adb @@ -29,7 +29,7 @@ package body Ada.Containers.Helpers is package body Generic_Implementation is - use SAC; + use type SAC.Atomic_Unsigned; ------------ -- Adjust -- @@ -53,7 +53,7 @@ package body Ada.Containers.Helpers is procedure Busy (T_Counts : in out Tamper_Counts) is begin if T_Check then - Increment (T_Counts.Busy); + SAC.Increment (T_Counts.Busy); end if; end Busy; @@ -118,8 +118,8 @@ package body Ada.Containers.Helpers is procedure Lock (T_Counts : in out Tamper_Counts) is begin if T_Check then - Increment (T_Counts.Lock); - Increment (T_Counts.Busy); + SAC.Increment (T_Counts.Lock); + SAC.Increment (T_Counts.Busy); end if; end Lock; @@ -133,6 +133,13 @@ package body Ada.Containers.Helpers is raise Program_Error with "attempt to tamper with cursors"; end if; + + -- The lock status (which monitors "element tampering") always + -- implies that the busy status (which monitors "cursor tampering") + -- is set too; this is a representation invariant. Thus if the busy + -- bit is not set, then the lock bit must not be set either. + + pragma Assert (T_Counts.Lock = 0); end TC_Check; -------------- @@ -154,7 +161,7 @@ package body Ada.Containers.Helpers is procedure Unbusy (T_Counts : in out Tamper_Counts) is begin if T_Check then - Decrement (T_Counts.Busy); + SAC.Decrement (T_Counts.Busy); end if; end Unbusy; @@ -165,8 +172,8 @@ package body Ada.Containers.Helpers is procedure Unlock (T_Counts : in out Tamper_Counts) is begin if T_Check then - Decrement (T_Counts.Lock); - Decrement (T_Counts.Busy); + SAC.Decrement (T_Counts.Lock); + SAC.Decrement (T_Counts.Busy); end if; end Unlock; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 404d1f59598..cae5fa0180a 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -38,7 +38,7 @@ package body Ada.Containers.Vectors is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers + -- See comment in Ada.Containers.Helpers procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -276,23 +276,17 @@ package body Ada.Containers.Vectors is end if; end if; - if T_Check then - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - else + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with null)); - end if; + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; function Constant_Reference @@ -304,23 +298,17 @@ package body Ada.Containers.Vectors is raise Constraint_Error with "Index is out of range"; end if; - if T_Check then - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - else + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with null)); - end if; + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; -------------- @@ -2401,23 +2389,17 @@ package body Ada.Containers.Vectors is end if; end if; - if T_Check then - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - else + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin return R : constant Reference_Type := (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with null)); - end if; + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; function Reference @@ -2429,23 +2411,17 @@ package body Ada.Containers.Vectors is raise Constraint_Error with "Index is out of range"; end if; - if T_Check then - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - else + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin return R : constant Reference_Type := (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with null)); - end if; + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index c217a4f6d68..3ad48e6a074 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); @@ -41,6 +43,10 @@ package body Ada.Containers.Ordered_Maps is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -125,11 +131,11 @@ package body Ada.Containers.Ordered_Maps is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; @@ -144,7 +150,7 @@ package body Ada.Containers.Ordered_Maps is function "<" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; @@ -156,7 +162,7 @@ package body Ada.Containers.Ordered_Maps is function "<" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; @@ -181,11 +187,11 @@ package body Ada.Containers.Ordered_Maps is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; @@ -200,7 +206,7 @@ package body Ada.Containers.Ordered_Maps is function ">" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; @@ -212,7 +218,7 @@ package body Ada.Containers.Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; @@ -234,20 +240,6 @@ package body Ada.Containers.Ordered_Maps is Adjust (Container.Tree); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - T : Tree_Type renames Control.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -323,12 +315,13 @@ package body Ada.Containers.Ordered_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -338,15 +331,14 @@ package body Ada.Containers.Ordered_Maps is declare T : Tree_Type renames Position.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -358,21 +350,20 @@ package body Ada.Containers.Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; declare T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -421,12 +412,13 @@ package body Ada.Containers.Ordered_Maps is Tree : Tree_Type renames Container.Tree; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; @@ -444,7 +436,7 @@ package body Ada.Containers.Ordered_Maps is X : Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "key not in map"; end if; @@ -486,7 +478,7 @@ package body Ada.Containers.Ordered_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; @@ -501,7 +493,7 @@ package body Ada.Containers.Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; @@ -544,27 +536,7 @@ package body Ada.Containers.Ordered_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Tree.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - T : Tree_Type renames Control.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.Tree.TC); end if; end Finalize; @@ -622,11 +594,11 @@ package body Ada.Containers.Ordered_Maps is function First_Element (Container : Map) return Element_Type is T : Tree_Type renames Container.Tree; begin - if T.First = null then + if Checks and then T.First = null then raise Constraint_Error with "map is empty"; - else - return T.First.Element; end if; + + return T.First.Element; end First_Element; --------------- @@ -636,11 +608,11 @@ package body Ada.Containers.Ordered_Maps is function First_Key (Container : Map) return Key_Type is T : Tree_Type renames Container.Tree; begin - if T.First = null then + if Checks and then T.First = null then raise Constraint_Error with "map is empty"; - else - return T.First.Key; end if; + + return T.First.Key; end First_Key; ----------- @@ -712,10 +684,7 @@ package body Ada.Containers.Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); Position.Node.Key := Key; Position.Node.Element := New_Item; @@ -781,7 +750,7 @@ package body Ada.Containers.Ordered_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "key already in map"; end if; end Insert; @@ -902,29 +871,17 @@ package body Ada.Containers.Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container.Tree); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container.Tree); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -941,15 +898,13 @@ package body Ada.Containers.Ordered_Maps is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; function Iterate (Container : Map; Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -962,12 +917,12 @@ package body Ada.Containers.Ordered_Maps is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong map"; end if; @@ -989,7 +944,7 @@ package body Ada.Containers.Ordered_Maps is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -999,7 +954,7 @@ package body Ada.Containers.Ordered_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; @@ -1053,11 +1008,11 @@ package body Ada.Containers.Ordered_Maps is function Last_Element (Container : Map) return Element_Type is T : Tree_Type renames Container.Tree; begin - if T.Last = null then + if Checks and then T.Last = null then raise Constraint_Error with "map is empty"; - else - return T.Last.Element; end if; + + return T.Last.Element; end Last_Element; -------------- @@ -1067,11 +1022,11 @@ package body Ada.Containers.Ordered_Maps is function Last_Key (Container : Map) return Key_Type is T : Tree_Type renames Container.Tree; begin - if T.Last = null then + if Checks and then T.Last = null then raise Constraint_Error with "map is empty"; - else - return T.Last.Key; end if; + + return T.Last.Key; end Last_Key; ---------- @@ -1143,7 +1098,7 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -1200,7 +1155,7 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong map"; end if; @@ -1215,15 +1170,11 @@ package body Ada.Containers.Ordered_Maps is function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type is - C : constant Map_Access := Container'Unrestricted_Access; - B : Natural renames C.Tree.Busy; - L : Natural renames C.Tree.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -1237,7 +1188,7 @@ package body Ada.Containers.Ordered_Maps is Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -1247,29 +1198,11 @@ package body Ada.Containers.Ordered_Maps is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Query_Element; @@ -1345,12 +1278,13 @@ package body Ada.Containers.Ordered_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -1360,15 +1294,14 @@ package body Ada.Containers.Ordered_Maps is declare T : Tree_Type renames Position.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1380,21 +1313,20 @@ package body Ada.Containers.Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; declare T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1411,14 +1343,11 @@ package body Ada.Containers.Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); Node.Key := Key; Node.Element := New_Item; @@ -1434,20 +1363,18 @@ package body Ada.Containers.Ordered_Maps is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); pragma Assert (Vet (Container.Tree, Position.Node), "Position cursor of Replace_Element is bad"); @@ -1478,22 +1405,12 @@ package body Ada.Containers.Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container.Tree); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (Container.Tree); end Reverse_Iterate; ----------- @@ -1555,12 +1472,13 @@ package body Ada.Containers.Ordered_Maps is Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1570,30 +1488,11 @@ package body Ada.Containers.Ordered_Maps is declare T : Tree_Type renames Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - - begin - Process (K, E); - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Update_Element; diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index 56a98fbc0e4..56877803187 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -261,7 +261,7 @@ private overriding procedure Finalize (Container : in out Map) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -297,16 +297,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Map_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -364,19 +356,14 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_Map : constant Map := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + Empty_Map : constant Map := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -385,7 +372,8 @@ private record Container : Map_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb index c3e4fce66e4..1b9852f0975 100644 --- a/gcc/ada/a-coormu.adb +++ b/gcc/ada/a-coormu.adb @@ -44,6 +44,10 @@ package body Ada.Containers.Ordered_Multisets is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -577,10 +581,8 @@ package body Ada.Containers.Ordered_Multisets is -------------- procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Tree.Busy; - pragma Assert (B > 0); begin - B := B - 1; + Unbusy (Object.Container.Tree.TC); end Finalize; ---------- @@ -887,22 +889,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T, Key); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T, Key); end Iterate; --------- @@ -947,22 +939,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T, Key); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T, Key); end Reverse_Iterate; -------------------- @@ -994,25 +976,9 @@ package body Ada.Containers.Ordered_Multisets is declare E : Element_Type renames Node.Element; K : constant Key_Type := Key (E); - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (E); if Equivalent_Keys (Left => K, Right => Key (E)) then return; @@ -1283,22 +1249,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T); end Iterate; procedure Iterate @@ -1322,30 +1278,18 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T, Item); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T, Item); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'Class is S : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames S.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1358,7 +1302,7 @@ package body Ada.Containers.Ordered_Multisets is -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := (Limited_Controlled with S, null) do - B := B + 1; + Busy (S.Tree.TC); end return; end Iterate; @@ -1366,8 +1310,6 @@ package body Ada.Containers.Ordered_Multisets is return Set_Iterator_Interfaces.Reversible_Iterator'Class is S : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames S.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1405,7 +1347,7 @@ package body Ada.Containers.Ordered_Multisets is return It : constant Iterator := (Limited_Controlled with S, Start.Node) do - B := B + 1; + Busy (S.Tree.TC); end return; end Iterate; @@ -1609,25 +1551,9 @@ package body Ada.Containers.Ordered_Multisets is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element); end; end Query_Element; @@ -1700,10 +1626,7 @@ package body Ada.Containers.Ordered_Multisets is then null; else - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); Node.Element := Item; return; @@ -1796,22 +1719,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T); end Reverse_Iterate; procedure Reverse_Iterate @@ -1835,22 +1748,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T, Item); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T, Item); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads index 51785820b50..db47c19f676 100644 --- a/gcc/ada/a-coormu.ads +++ b/gcc/ada/a-coormu.ads @@ -476,7 +476,7 @@ private overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -543,20 +543,15 @@ private for Constant_Reference_Type'Write use Write; - Empty_Set : constant Set := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + Empty_Set : constant Set := (Controlled with others => <>); type Iterator is new Limited_Controlled and Set_Iterator_Interfaces.Reversible_Iterator with record Container : Set_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index fde98bf5f2d..a92ed7f704a 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); @@ -44,6 +46,10 @@ package body Ada.Containers.Ordered_Sets is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ------------------------------ -- Access to Fields of Node -- ------------------------------ @@ -157,11 +163,11 @@ package body Ada.Containers.Ordered_Sets is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -176,7 +182,7 @@ package body Ada.Containers.Ordered_Sets is function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; @@ -188,7 +194,7 @@ package body Ada.Containers.Ordered_Sets is function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -213,11 +219,11 @@ package body Ada.Containers.Ordered_Sets is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -234,7 +240,7 @@ package body Ada.Containers.Ordered_Sets is function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -246,7 +252,7 @@ package body Ada.Containers.Ordered_Sets is function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; @@ -267,20 +273,6 @@ package body Ada.Containers.Ordered_Sets is Adjust (Container.Tree); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -336,11 +328,12 @@ package body Ada.Containers.Ordered_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -351,15 +344,14 @@ package body Ada.Containers.Ordered_Sets is declare Tree : Tree_Type renames Position.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -408,11 +400,12 @@ package body Ada.Containers.Ordered_Sets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -428,7 +421,7 @@ package body Ada.Containers.Ordered_Sets is X : Node_Access := Element_Keys.Find (Container.Tree, Item); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -485,7 +478,7 @@ package body Ada.Containers.Ordered_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -553,27 +546,7 @@ package body Ada.Containers.Ordered_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Tree.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.Tree.TC); end if; end Finalize; @@ -627,7 +600,7 @@ package body Ada.Containers.Ordered_Sets is function First_Element (Container : Set) return Element_Type is begin - if Container.Tree.First = null then + if Checks and then Container.Tree.First = null then raise Constraint_Error with "set is empty"; end if; @@ -692,24 +665,6 @@ package body Ada.Containers.Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------- -- Ceiling -- ------------- @@ -732,21 +687,20 @@ package body Ada.Containers.Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; declare Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -768,7 +722,7 @@ package body Ada.Containers.Ordered_Sets is X : Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -784,7 +738,7 @@ package body Ada.Containers.Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; @@ -820,16 +774,10 @@ package body Ada.Containers.Ordered_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B - 1; - L := L - 1; - end; - - if not (Key (Control.Pos) = Control.Old_Key.all) then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then Delete (Control.Container.all, Key (Control.Pos)); raise Program_Error; end if; @@ -891,7 +839,7 @@ package body Ada.Containers.Ordered_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -923,11 +871,12 @@ package body Ada.Containers.Ordered_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -938,20 +887,17 @@ package body Ada.Containers.Ordered_Sets is declare Tree : Tree_Type renames Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, Control => (Controlled with + Tree.TC'Unrestricted_Access, Container => Container'Access, Pos => Position, Old_Key => new Key_Type'(Key (Position)))) do - B := B + 1; - L := L + 1; + Lock (Tree.TC); end return; end; end Reference_Preserving_Key; @@ -963,26 +909,23 @@ package body Ada.Containers.Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then - raise Constraint_Error with "key not in set"; + if Checks and then Node = null then + raise Constraint_Error with "Key not in set"; end if; declare Tree : Tree_Type renames Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin return R : constant Reference_Type := (Element => Node.Element'Access, Control => (Controlled with + Tree.TC'Unrestricted_Access, Container => Container'Access, Pos => Find (Container, Key), Old_Key => new Key_Type'(Key))) do - B := B + 1; - L := L + 1; + Lock (Tree.TC); end return; end; end Reference_Preserving_Key; @@ -999,7 +942,7 @@ package body Ada.Containers.Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -1019,12 +962,13 @@ package body Ada.Containers.Ordered_Sets is Tree : Tree_Type renames Container.Tree; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1035,30 +979,10 @@ package body Ada.Containers.Ordered_Sets is declare E : Element_Type renames Position.Node.Element; K : constant Key_Type := Key (E); - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - - Eq : Boolean; - + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Eq then + Process (E); + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -1118,10 +1042,7 @@ package body Ada.Containers.Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.Tree.TC); Position.Node.Element := New_Item; end if; @@ -1159,7 +1080,7 @@ package body Ada.Containers.Ordered_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -1362,29 +1283,17 @@ package body Ada.Containers.Ordered_Sets is end Process_Node; T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1396,7 +1305,7 @@ package body Ada.Containers.Ordered_Sets is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); return It : constant Iterator := Iterator'(Limited_Controlled with @@ -1407,8 +1316,6 @@ package body Ada.Containers.Ordered_Sets is function Iterate (Container : Set; Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1421,12 +1328,12 @@ package body Ada.Containers.Ordered_Sets is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong set"; end if; @@ -1443,7 +1350,7 @@ package body Ada.Containers.Ordered_Sets is -- the start position has the same value irrespective of whether this is -- a forward or reverse iteration. - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); return It : constant Iterator := Iterator'(Limited_Controlled with @@ -1490,11 +1397,11 @@ package body Ada.Containers.Ordered_Sets is function Last_Element (Container : Set) return Element_Type is begin - if Container.Tree.Last = null then + if Checks and then Container.Tree.Last = null then raise Constraint_Error with "set is empty"; - else - return Container.Tree.Last.Element; end if; + + return Container.Tree.Last.Element; end Last_Element; ---------- @@ -1559,7 +1466,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1618,7 +1525,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong set"; end if; @@ -1633,15 +1540,11 @@ package body Ada.Containers.Ordered_Sets is function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type is - C : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames C.Tree.Busy; - L : Natural renames C.Tree.Lock; - begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -1654,7 +1557,7 @@ package body Ada.Containers.Ordered_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -1663,25 +1566,9 @@ package body Ada.Containers.Ordered_Sets is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element); end; end Query_Element; @@ -1748,15 +1635,12 @@ package body Ada.Containers.Ordered_Sets is Element_Keys.Find (Container.Tree, New_Item); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.Tree.TC); Node.Element := New_Item; end Replace; @@ -1805,12 +1689,6 @@ package body Ada.Containers.Ordered_Sets is Inserted : Boolean; Compare : Boolean; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - -- Start of processing for Replace_Element begin @@ -1828,33 +1706,19 @@ package body Ada.Containers.Ordered_Sets is -- Determine whether Item is equivalent to element on the specified -- node. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := (if Item < Node.Element then False elsif Node.Element < Item then False else True); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then -- Item is equivalent to the node's element, so we will not have to -- move the node. - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); Node.Element := Item; return; @@ -1872,26 +1736,15 @@ package body Ada.Containers.Ordered_Sets is Hint := Element_Keys.Ceiling (Tree, Item); if Hint /= null then + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Item < Hint.Element; - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; -- Item >= Hint.Element - if not Compare then + if Checks and then not Compare then -- Ceiling returns an element that is equivalent or greater -- than Item. If Item is "not less than" the element, then @@ -1922,10 +1775,7 @@ package body Ada.Containers.Ordered_Sets is -- because it would only be placed in the exact same position. if Hint = Node then - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); Node.Element := Item; return; @@ -1958,12 +1808,13 @@ package body Ada.Containers.Ordered_Sets is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1998,22 +1849,12 @@ package body Ada.Containers.Ordered_Sets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index f574f3c92ca..d2e882a7f82 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +private with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; @@ -283,17 +284,16 @@ package Ada.Containers.Ordered_Sets is type Key_Access is access all Key_Type; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Pos : Cursor; Old_Key : Key_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); @@ -344,7 +344,7 @@ private overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -380,16 +380,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Set_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); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -425,19 +417,14 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_Set : constant Set := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + Empty_Set : constant Set := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -446,7 +433,8 @@ private record Container : Set_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads index 2991d36ee06..73ed9ae6741 100644 --- a/gcc/ada/a-crbltr.ads +++ b/gcc/ada/a-crbltr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +29,8 @@ -- This package declares the tree type used to implement ordered containers +with Ada.Containers.Helpers; + package Ada.Containers.Red_Black_Trees is pragma Pure; @@ -38,14 +40,16 @@ package Ada.Containers.Red_Black_Trees is type Node_Type (<>) is limited private; type Node_Access is access Node_Type; package Generic_Tree_Types is + type Tree_Type is tagged record - First : Node_Access; - Last : Node_Access; - Root : Node_Access; + First : Node_Access := null; + Last : Node_Access := null; + Root : Node_Access := null; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Helpers.Tamper_Counts; end record; + + package Implementation is new Helpers.Generic_Implementation; end Generic_Tree_Types; generic @@ -65,11 +69,12 @@ package Ada.Containers.Red_Black_Trees is Last : Count_Type := 0; Root : Count_Type := 0; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Helpers.Tamper_Counts; Free : Count_Type'Base := -1; Nodes : Nodes_Type (1 .. Capacity) := (others => <>); end record; + + package Implementation is new Helpers.Generic_Implementation; end Generic_Bounded_Tree_Types; end Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb index ae8dd7c6c7a..10a9e92ba0d 100644 --- a/gcc/ada/a-crbtgk.adb +++ b/gcc/ada/a-crbtgk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +29,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + package Ops renames Tree_Operations; ------------- @@ -38,8 +42,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- AKA Lower_Bound function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is - B : Natural renames Tree'Unrestricted_Access.Busy; - L : Natural renames Tree'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); Y : Node_Access; X : Node_Access; @@ -52,12 +58,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return null; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - X := Tree.Root; while X /= null loop if Is_Greater_Key_Node (Key, X) then @@ -68,17 +68,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; - B := B - 1; - L := L - 1; - return Y; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end Ceiling; ---------- @@ -86,14 +76,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ---------- function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is - B : Natural renames Tree'Unrestricted_Access.Busy; - L : Natural renames Tree'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); Y : Node_Access; X : Node_Access; - Result : Node_Access; - begin -- If the container is empty, return a result immediately, so that we do -- not manipulate the tamper bits unnecessarily. @@ -102,12 +92,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return null; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - X := Tree.Root; while X /= null loop if Is_Greater_Key_Node (Key, X) then @@ -118,27 +102,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; - if Y = null then - Result := null; - - elsif Is_Less_Key_Node (Key, Y) then - Result := null; - + if Y = null or else Is_Less_Key_Node (Key, Y) then + return null; else - Result := Y; + return Y; end if; - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end Find; ----------- @@ -146,8 +114,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ----------- function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is - B : Natural renames Tree'Unrestricted_Access.Busy; - L : Natural renames Tree'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); Y : Node_Access; X : Node_Access; @@ -160,12 +130,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return null; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - X := Tree.Root; while X /= null loop if Is_Less_Key_Node (Key, X) then @@ -176,17 +140,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; - B := B - 1; - L := L - 1; - return Y; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end Floor; -------------------------------- @@ -202,12 +156,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is X : Node_Access; Y : Node_Access; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - Compare : Boolean; begin @@ -235,10 +183,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- either the smallest node greater than Key (Inserted is True), or the -- largest node less or equivalent to Key (Inserted is False). + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - X := Tree.Root; Y := null; Inserted := True; @@ -247,16 +194,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Inserted := Is_Less_Key_Node (Key, X); X := (if Inserted then Ops.Left (X) else Ops.Right (X)); end loop; - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Inserted then @@ -288,21 +225,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- Key is equivalent to or greater than Node. We must resolve which is -- the case, to determine whether the conditional insertion succeeds. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Greater_Key_Node (Key, Node); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -334,12 +260,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Node : out Node_Access; Inserted : out Boolean) is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - Test : Node_Access; Compare : Boolean; @@ -366,21 +286,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- we must search. if Position = null then -- largest + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Greater_Key_Node (Key, Tree.Last); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -412,21 +321,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- then its neighbor must be anterior and so we insert before the -- hint. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Less_Key_Node (Key, Position); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -439,21 +337,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return; end if; + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Greater_Key_Node (Key, Test); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -478,21 +365,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- less than the hint's next neighbor, then we're done; otherwise we -- must search. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Greater_Key_Node (Key, Position); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -505,21 +381,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return; end if; + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Less_Key_Node (Key, Test); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -557,14 +422,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Z : out Node_Access) is begin - if Tree.Length = Count_Type'Last then + if Checks and then Tree.Length = Count_Type'Last then raise Constraint_Error with "too many elements"; end if; - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); Z := New_Node; pragma Assert (Z /= null); diff --git a/gcc/ada/a-crbtgk.ads b/gcc/ada/a-crbtgk.ads index b2c21cdb0df..c93dfe7ba6a 100644 --- a/gcc/ada/a-crbtgk.ads +++ b/gcc/ada/a-crbtgk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +35,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Operations; generic with package Tree_Operations is new Generic_Operations (<>); - use Tree_Operations.Tree_Types; + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; type Key_Type (<>) is limited private; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index a75f069acb7..e656295f683 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +38,10 @@ with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -258,10 +262,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is pragma Assert (Z /= null); begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); -- Why are these all commented out ??? @@ -511,12 +512,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Generic_Adjust (Tree : in out Tree_Type) is N : constant Count_Type := Tree.Length; Root : constant Node_Access := Tree.Root; - + use type Helpers.Tamper_Counts; begin if N = 0 then pragma Assert (Root = null); - pragma Assert (Tree.Busy = 0); - pragma Assert (Tree.Lock = 0); + pragma Assert (Tree.TC = (Busy => 0, Lock => 0)); return; end if; @@ -538,17 +538,13 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Generic_Clear (Tree : in out Tree_Type) is Root : Node_Access := Tree.Root; begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); Tree := (First => null, Last => null, Root => null, Length => 0, - Busy => 0, - Lock => 0); + TC => <>); Delete_Tree (Root); end Generic_Clear; @@ -627,17 +623,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ------------------- function Generic_Equal (Left, Right : Tree_Type) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Node_Access; R_Node : Node_Access; - - Result : Boolean; - begin if Left'Address = Right'Address then return True; @@ -654,45 +644,18 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is return True; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; - Result := True; while L_Node /= null loop if not Is_Equal (L_Node, R_Node) then - Result := False; - exit; + return False; end if; L_Node := Next (L_Node); R_Node := Next (R_Node); end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + return True; end Generic_Equal; ----------------------- @@ -732,10 +695,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Clear (Target); @@ -745,8 +705,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Last => null, Root => null, Length => 0, - Busy => 0, - Lock => 0); + TC => <>); end Generic_Move; ------------------ diff --git a/gcc/ada/a-crbtgo.ads b/gcc/ada/a-crbtgo.ads index f2787f608da..4c197417ae6 100644 --- a/gcc/ada/a-crbtgo.ads +++ b/gcc/ada/a-crbtgo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +34,7 @@ with Ada.Streams; use Ada.Streams; generic with package Tree_Types is new Generic_Tree_Types (<>); - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; with function Parent (Node : Node_Access) return Node_Access is <>; with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>; diff --git a/gcc/ada/a-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb index dba3e0bd095..abf7773522a 100644 --- a/gcc/ada/a-rbtgbk.adb +++ b/gcc/ada/a-rbtgbk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -349,12 +349,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is N : Nodes_Type renames Tree.Nodes; begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); - if Tree.Length >= Tree.Capacity then + if Checks and then Tree.Length >= Tree.Capacity then raise Capacity_Error with "not enough capacity to insert new item"; end if; diff --git a/gcc/ada/a-rbtgbk.ads b/gcc/ada/a-rbtgbk.ads index a96ef28cff3..1cf1cbc9cc4 100644 --- a/gcc/ada/a-rbtgbk.ads +++ b/gcc/ada/a-rbtgbk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +35,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; generic with package Tree_Operations is new Generic_Bounded_Operations (<>); - use Tree_Operations.Tree_Types; + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; type Key_Type (<>) is limited private; diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb index 100881bf013..b75974065d2 100644 --- a/gcc/ada/a-rbtgbo.adb +++ b/gcc/ada/a-rbtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +41,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -57,17 +61,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is procedure Clear_Tree (Tree : in out Tree_Type'Class) is begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - - -- The lock status (which monitors "element tampering") always implies - -- that the busy status (which monitors "cursor tampering") is set too; - -- this is a representation invariant. Thus if the busy bit is not set, - -- then the lock bit must not be set either. - - pragma Assert (Tree.Lock = 0); + TC_Check (Tree.TC); Tree.First := 0; Tree.Last := 0; @@ -201,10 +195,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is N : Nodes_Type renames Tree.Nodes; begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); -- If node is not present, return (exception will be raised in caller) @@ -612,17 +603,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is ------------------- function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; - Result : Boolean; - begin if Left'Address = Right'Address then return True; @@ -639,45 +628,18 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is return True; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; - Result := True; while L_Node /= 0 loop if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - Result := False; - exit; + return False; end if; L_Node := Next (Left, L_Node); R_Node := Next (Right, R_Node); end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + return True; end Generic_Equal; ----------------------- @@ -725,7 +687,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Clear_Tree (Tree); Count_Type'Base'Read (Stream, Len); - if Len < 0 then + if Checks and then Len < 0 then raise Program_Error with "bad container length (corrupt stream)"; end if; @@ -733,7 +695,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is return; end if; - if Len > Tree.Capacity then + if Checks and then Len > Tree.Capacity then raise Constraint_Error with "length exceeds capacity"; end if; diff --git a/gcc/ada/a-rbtgbo.ads b/gcc/ada/a-rbtgbo.ads index b6aae737fd3..2f8b7835582 100644 --- a/gcc/ada/a-rbtgbo.ads +++ b/gcc/ada/a-rbtgbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +34,7 @@ with Ada.Streams; use Ada.Streams; generic with package Tree_Types is new Generic_Bounded_Tree_Types (<>); - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; with function Parent (Node : Node_Type) return Count_Type is <>; diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb index 06a78e922c3..f6daa90ff1d 100644 --- a/gcc/ada/a-rbtgso.adb +++ b/gcc/ada/a-rbtgso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,10 @@ with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -44,8 +48,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ----------- procedure Clear (Tree : in out Tree_Type) is - pragma Assert (Tree.Busy = 0); - pragma Assert (Tree.Lock = 0); + use type Helpers.Tamper_Counts; + pragma Assert (Tree.TC = (Busy => 0, Lock => 0)); Root : Node_Access := Tree.Root; pragma Warnings (Off, Root); @@ -84,12 +88,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ---------------- procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Node_Access; Src : Node_Access; @@ -97,10 +95,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is begin if Target'Address = Source'Address then - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); Clear (Target); return; @@ -110,10 +105,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); Tgt := Target.First; Src := Source.First; @@ -129,13 +121,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Tgt, Src) then Compare := -1; elsif Is_Less (Src, Tgt) then @@ -143,22 +132,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -199,11 +172,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); Tree : Tree_Type; @@ -214,12 +184,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -259,22 +223,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - return Tree; exception when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - Delete_Tree (Tree.Root); raise; end; @@ -288,12 +240,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (Target : in out Tree_Type; Source : Tree_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Node_Access; Src : Node_Access; @@ -304,10 +250,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); if Source.Length = 0 then Clear (Target); @@ -322,13 +265,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Tgt, Src) then Compare := -1; elsif Is_Less (Src, Tgt) then @@ -336,22 +276,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -393,11 +317,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); Tree : Tree_Type; @@ -408,12 +329,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -443,22 +358,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - return Tree; exception when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - Delete_Tree (Tree.Root); raise; end; @@ -485,40 +388,26 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Subset'Unrestricted_Access.Busy; - LL : Natural renames Subset'Unrestricted_Access.Lock; - - BR : Natural renames Of_Set'Unrestricted_Access.Busy; - LR : Natural renames Of_Set'Unrestricted_Access.Lock; + Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); + Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); Subset_Node : Node_Access; Set_Node : Node_Access; - Result : Boolean; - begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - Subset_Node := Subset.First; Set_Node := Of_Set.First; loop if Set_Node = null then - Result := Subset_Node = null; - exit; + return Subset_Node = null; end if; if Subset_Node = null then - Result := True; - exit; + return True; end if; if Is_Less (Subset_Node, Set_Node) then - Result := False; - exit; + return False; end if; if Is_Less (Set_Node, Subset_Node) then @@ -528,24 +417,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Subset_Node := Tree_Operations.Next (Subset_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end Is_Subset; @@ -563,32 +434,19 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Node_Access; R_Node : Node_Access; - - Result : Boolean; - begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop if L_Node = null or else R_Node = null then - Result := False; - exit; + return False; end if; if Is_Less (L_Node, R_Node) then @@ -598,28 +456,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is R_Node := Tree_Operations.Next (R_Node); else - Result := True; - exit; + return True; end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end Overlap; @@ -631,12 +470,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (Target : in out Tree_Type; Source : Tree_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Node_Access; Src : Node_Access; @@ -675,13 +508,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Tgt, Src) then Compare := -1; elsif Is_Less (Src, Tgt) then @@ -689,22 +519,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -751,11 +565,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); Tree : Tree_Type; @@ -766,12 +577,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -826,22 +631,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - return Tree; exception when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - Delete_Tree (Tree.Root); raise; end; @@ -883,24 +676,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BS := BS + 1; - LS := LS + 1; - Iterate (Source); - - BS := BS - 1; - LS := LS - 1; - - exception - when others => - BS := BS - 1; - LS := LS - 1; - - raise; end; end Union; @@ -919,11 +697,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); Tree : Tree_Type := Copy (Left); @@ -951,30 +726,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Start of processing for Union begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - Iterate (Right); - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - return Tree; exception when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - Delete_Tree (Tree.Root); raise; end; diff --git a/gcc/ada/a-rbtgso.ads b/gcc/ada/a-rbtgso.ads index 26ff8fb849b..9ad296fe090 100644 --- a/gcc/ada/a-rbtgso.ads +++ b/gcc/ada/a-rbtgso.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +35,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Operations; generic with package Tree_Operations is new Generic_Operations (<>); - use Tree_Operations.Tree_Types; + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; with procedure Insert_With_Hint (Dst_Tree : in out Tree_Type; diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index a7d3628d917..ac0a09e0bbc 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -488,7 +488,7 @@ package Restrict is -- and this flag is not set. Profile is set to a non-default value if the -- No_Dependence restriction comes from a Profile pragma. This procedure -- also takes care of setting the Boolean2 flag of the simple name for - -- the entity (to optimize table searches). + -- the entity (to optimize table searches). procedure Set_Restriction_No_Use_Of_Pragma (N : Node_Id; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9ba25d5e0de..95624e69401 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3194,8 +3194,6 @@ package body Sem_Ch13 is goto Continue; end if; - Analyze_And_Resolve (Expr, Standard_Boolean); - -- If we're in a generic template, we don't want to try -- to disable controlled types, because typical usage is -- "Disable_Controlled => not <some_check>'Enabled", and @@ -3203,6 +3201,8 @@ package body Sem_Ch13 is -- particular instance. if Expander_Active then + Analyze_And_Resolve (Expr, Standard_Boolean); + if not Present (Expr) or else Is_True (Static_Boolean (Expr)) then |