diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 52 | ||||
| -rw-r--r-- | gcc/ada/a-btgbso.adb | 730 | ||||
| -rw-r--r-- | gcc/ada/a-cborse.adb | 123 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.adb | 120 | ||||
| -rw-r--r-- | gcc/ada/a-coorse.adb | 128 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgk.adb | 280 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgo.adb | 40 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgbo.adb | 39 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgso.adb | 685 | ||||
| -rw-r--r-- | gcc/ada/cio.c | 16 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 144 | ||||
| -rw-r--r-- | gcc/ada/prj-attr.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/prj-makr.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/projects.texi | 25 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 1 | ||||
| -rw-r--r-- | gcc/ada/urealp.ads | 6 |
17 files changed, 1911 insertions, 495 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 56fa2a2..19a4700 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,55 @@ +2013-04-11 Johannes Kanig <kanig@adacore.com> + + * debug.adb: Document usage of -gnatd.Q switch. + +2013-04-11 Matthew Heaney <heaney@adacore.com> + + * a-crbtgk.adb (Ceiling, Find, Floor): Adjust locks + before element comparisons. + (Generic_Conditional_Insert, Generic_Conditional_Insert_With_Hint): + Ditto. + * a-crbtgo.adb, a-rbtgbo.adb (Generic_Equal): Adjust locks before + element comparisons. + * a-rbtgso.adb (Difference, Intersection): Adjust locks + before element comparisons. + (Is_Subset, Overlap): Ditto + (Symmetric_Difference, Union): Ditto + * a-btgbso.adb (Set_Difference, Set_Intersection): Adjust locks + before element comparisons. + (Set_Subset, Set_Overlap): Ditto + (Set_Symmetric_Difference, Set_Union): Ditto + * a-coorse.adb, a-ciorse.adb, a-cborse.adb + (Update_Element_Preserving_Key): Adjust locks before element + comparisons (Replace_Element): Ditto + +2013-04-11 Pascal Obry <obry@adacore.com> + + * prj-attr.adb, projects.texi, snames.ads-tmpl: Remove Build_Slaves + attribute. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * exp_ch3.adb (Build_Equivalent_Aggregate): Subsidiary of + Expand_N_Object_Declaration, used to construct an aggregate + with static components whenever possible, so that objects of a + discriminated type can be initialized without calling the init. + proc for the type. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * prj-makr.adb (Process_Directory): On VMS, always delete, + then recreate the temporary file with Create_Output_Text_File, + otherwise the output redirection does not work properly. + +2013-04-11 Eric Botcazou <ebotcazou@adacore.com> + + * urealp.ads: Fix minor typo. + +2013-04-11 Fabien Chouteau <chouteau@adacore.com> + + * cio.c (mktemp): Don't use tmpnam function from the + system on VxWorks in kernel mode. + 2013-04-11 Vincent Celier <celier@adacore.com> * make.adb (Compile): Clarify the error message reported diff --git a/gcc/ada/a-btgbso.adb b/gcc/ada/a-btgbso.adb index b62007a..2aef270 100644 --- a/gcc/ada/a-btgbso.adb +++ b/gcc/ada/a-btgbso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -53,11 +53,19 @@ 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; SN : Nodes_Type renames Source.Nodes; + Compare : Integer; + begin if Target'Address = Source'Address then if Target.Busy > 0 then @@ -82,17 +90,51 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Src := Source.First; loop if Tgt = 0 then - return; + exit; end if; if Src = 0 then - return; + exit; end if; - if Is_Less (TN (Tgt), SN (Src)) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + 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 + Compare := 1; + 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 Tgt := Tree_Operations.Next (Target, Tgt); - elsif Is_Less (SN (Src), TN (Tgt)) then + elsif Compare > 0 then Src := Tree_Operations.Next (Source, Src); else @@ -111,12 +153,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end Set_Difference; function Set_Difference (Left, Right : Set_Type) return Set_Type is - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then return S : Set_Type (0); -- Empty set @@ -131,15 +167,51 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end if; return Result : Set_Type (Left.Length) do - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - return; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if R_Node = 0 then - while L_Node /= 0 loop + 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; + + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + 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 + if L_Node = 0 then + exit; + end if; + + if R_Node = 0 then + while L_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + end loop; + + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then Insert_With_Hint (Dst_Set => Result, Dst_Hint => 0, @@ -147,28 +219,31 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Dst_Node => Dst_Node); L_Node := Tree_Operations.Next (Left, L_Node); - end loop; - return; - end if; + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); + else + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; - L_Node := Tree_Operations.Next (Left, L_Node); + BL := BL - 1; + LL := LL - 1; - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); + BR := BR - 1; + LR := LR - 1; + exception + when others => + BL := BL - 1; + LL := LL - 1; - else - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; + BR := BR - 1; + LR := LR - 1; + + raise; + end; end return; end Set_Difference; @@ -180,9 +255,17 @@ 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; + Compare : Integer; + begin if Target'Address = Source'Address then return; @@ -203,7 +286,41 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is while Tgt /= 0 and then Src /= 0 loop - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + 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 + Compare := 1; + 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 declare X : constant Count_Type := Tgt; begin @@ -213,7 +330,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Tree_Operations.Free (Target, X); end; - elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + elsif Compare > 0 then Src := Tree_Operations.Next (Source, Src); else @@ -235,46 +352,80 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end Set_Intersection; function Set_Intersection (Left, Right : Set_Type) return Set_Type is - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then return Copy (Left); end if; return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - return; - end if; - if R_Node = 0 then - return; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - L_Node := Tree_Operations.Next (Left, L_Node); + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - else - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); + L_Node : Count_Type; + R_Node : Count_Type; - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; + Dst_Node : Count_Type; + 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 + if L_Node = 0 then + exit; + end if; + + if R_Node = 0 then + exit; + 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 + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + 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; @@ -286,9 +437,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is (Subset : Set_Type; Of_Set : Set_Type) return Boolean is - Subset_Node : Count_Type; - Set_Node : Count_Type; - begin if Subset'Address = Of_Set'Address then return True; @@ -298,28 +446,75 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return False; end if; - Subset_Node := Subset.First; - Set_Node := Of_Set.First; - loop - if Set_Node = 0 then - return Subset_Node = 0; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if Subset_Node = 0 then - return True; - end if; + declare + BL : Natural renames Subset'Unrestricted_Access.Busy; + LL : Natural renames Subset'Unrestricted_Access.Lock; - if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then - return False; - end if; + BR : Natural renames Of_Set'Unrestricted_Access.Busy; + LR : Natural renames Of_Set'Unrestricted_Access.Lock; - if Is_Less (Of_Set.Nodes (Set_Node), Subset.Nodes (Subset_Node)) then - Set_Node := Tree_Operations.Next (Of_Set, Set_Node); - else - Set_Node := Tree_Operations.Next (Of_Set, Set_Node); - Subset_Node := Tree_Operations.Next (Subset, Subset_Node); - end if; - end loop; + 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; + end if; + + if Subset_Node = 0 then + Result := True; + exit; + end if; + + if Is_Less (Subset.Nodes (Subset_Node), + Of_Set.Nodes (Set_Node)) + then + Result := False; + exit; + end if; + + if Is_Less (Of_Set.Nodes (Set_Node), + Subset.Nodes (Subset_Node)) + then + Set_Node := Tree_Operations.Next (Of_Set, Set_Node); + else + Set_Node := Tree_Operations.Next (Of_Set, Set_Node); + 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; ------------- @@ -327,33 +522,72 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ------------- function Set_Overlap (Left, Right : Set_Type) return Boolean is - L_Node : Count_Type; - R_Node : Count_Type; - begin if Left'Address = Right'Address then return Left.Length /= 0; end if; - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 - or else R_Node = 0 - then - return False; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - L_Node := Tree_Operations.Next (Left, L_Node); + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - else - return True; - end if; - end loop; + 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; + 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; + 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; -------------------------- @@ -364,18 +598,21 @@ 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; New_Tgt_Node : Count_Type; pragma Warnings (Off, New_Tgt_Node); - begin - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + Compare : Integer; + begin if Target'Address = Source'Address then Tree_Operations.Clear_Tree (Target); return; @@ -402,10 +639,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return; end if; - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + 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 + Compare := 1; + 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 Tgt := Tree_Operations.Next (Target, Tgt); - elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + elsif Compare > 0 then Insert_With_Hint (Dst_Set => Target, Dst_Hint => Tgt, @@ -432,12 +703,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is function Set_Symmetric_Difference (Left, Right : Set_Type) return Set_Type is - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then return S : Set_Type (0); -- Empty set @@ -452,25 +717,62 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end if; return Result : Set_Type (Left.Length + Right.Length) do - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - while R_Node /= 0 loop - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Right.Nodes (R_Node), - Dst_Node => Dst_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end loop; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - return; - end if; + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - if R_Node = 0 then - while L_Node /= 0 loop + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + 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 + if L_Node = 0 then + while R_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Right.Nodes (R_Node), + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (Right, R_Node); + end loop; + + exit; + end if; + + if R_Node = 0 then + while L_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + end loop; + + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then Insert_With_Hint (Dst_Set => Result, Dst_Hint => 0, @@ -478,34 +780,37 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Dst_Node => Dst_Node); L_Node := Tree_Operations.Next (Left, L_Node); - end loop; - return; - end if; + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Right.Nodes (R_Node), + Dst_Node => Dst_Node); - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); + R_Node := Tree_Operations.Next (Right, R_Node); - L_Node := Tree_Operations.Next (Left, L_Node); + else + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Right.Nodes (R_Node), - Dst_Node => Dst_Node); + BL := BL - 1; + LL := LL - 1; - R_Node := Tree_Operations.Next (Right, R_Node); + BR := BR - 1; + LR := LR - 1; + exception + when others => + BL := BL - 1; + LL := LL - 1; - else - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; + BR := BR - 1; + LR := LR - 1; + + raise; + end; end return; end Set_Symmetric_Difference; @@ -541,17 +846,34 @@ 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; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - -- 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 target, - -- because equivalent items from source are not included in the union. + declare + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; - Iterate (Source); + 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 + -- target, because equivalent items from source are not included in + -- the union. + + Iterate (Source); + + BS := BS - 1; + LS := LS - 1; + exception + when others => + BS := BS - 1; + LS := LS - 1; + + raise; + end; end Set_Union; function Set_Union (Left, Right : Set_Type) return Set_Type is @@ -569,35 +891,65 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end if; return Result : Set_Type (Left.Length + Right.Length) do - Assign (Target => Result, Source => Left); + 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; + + begin + BL := BL + 1; + LL := LL + 1; - Insert_Right : declare - Hint : Count_Type := 0; + BR := BR + 1; + LR := LR + 1; - procedure Process (Node : Count_Type); - pragma Inline (Process); + Assign (Target => Result, Source => Left); - procedure Iterate is - new Tree_Operations.Generic_Iteration (Process); + Insert_Right : declare + Hint : Count_Type := 0; - ------------- - -- Process -- - ------------- + procedure Process (Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Count_Type) is + begin + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => Hint, + Src_Node => Right.Nodes (Node), + Dst_Node => Hint); + end Process; + + -- Start of processing for Insert_Right - procedure Process (Node : Count_Type) is begin - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => Hint, - Src_Node => Right.Nodes (Node), - Dst_Node => Hint); - end Process; + Iterate (Right); + end Insert_Right; - -- Start of processing for Insert_Right + BL := BL - 1; + LL := LL - 1; - begin - Iterate (Right); - end Insert_Right; + 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-cborse.adb b/gcc/ada/a-cborse.adb index 3131de1..ed34b69 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -979,6 +979,9 @@ package body Ada.Containers.Bounded_Ordered_Sets is pragma Assert (Vet (Container, Position.Node), "bad cursor in Update_Element_Preserving_Key"); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare N : Node_Type renames Container.Nodes (Position.Node); E : Element_Type renames N.Element; @@ -987,12 +990,15 @@ package body Ada.Containers.Bounded_Ordered_Sets is B : Natural renames Container.Busy; L : Natural renames Container.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin Process (E); + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -1003,7 +1009,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then + if Eq then return; end if; end; @@ -1727,16 +1733,52 @@ package body Ada.Containers.Bounded_Ordered_Sets is Hint : Count_Type; Result : Count_Type; 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 - if Item < Node.Element - or else Node.Element < Item - then - null; + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints, described as follows. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + 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. - else if Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (set is locked)"; @@ -1746,12 +1788,63 @@ package body Ada.Containers.Bounded_Ordered_Sets is return; end if; + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns 0. + Hint := Element_Keys.Ceiling (Container, Item); - if Hint = 0 then - null; + if Hint /= 0 then -- Item <= Nodes (Hint).Element + 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; + + if not Compare then -- Item is equivalent to Nodes (Hint).Element + -- Ceiling returns an element that is equivalent or greater than + -- Item. If Item is "not less than" the element, then by + -- elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree + -- (specifically, it is less then Nodes (Hint).Element), so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. - elsif Item < Nodes (Hint).Element then if Hint = Index then if Container.Lock > 0 then raise Program_Error with @@ -1761,12 +1854,14 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node.Element := Item; return; end if; - - else - pragma Assert (not (Nodes (Hint).Element < Item)); - raise Program_Error with "attempt to replace existing element"; end if; + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = 0), or because Item was less than some element at a + -- different place in the tree (Item < Nodes (Hint).Element and Hint /= + -- Index). In either case, we remove Node from the tree and then insert + -- Item into the tree, onto the same Node. + Tree_Operations.Delete_Node_Sans_Free (Container, Index); Local_Insert_With_Hint diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index a653866..4d918a5 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -1088,12 +1088,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is B : Natural renames Tree.Busy; L : Natural renames Tree.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin Process (E); + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -1104,7 +1107,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then + if Eq then return; end if; end; @@ -1884,16 +1887,54 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Hint : Node_Access; Result : Node_Access; Inserted : Boolean; + Compare : Boolean; X : Element_Access := Node.Element; - -- Start of processing for Replace_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 - if Item < Node.Element.all or else Node.Element.all < Item then - null; + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints, described as follows. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + 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. - else if Tree.Lock > 0 then raise Program_Error with "attempt to tamper with elements (set is locked)"; @@ -1914,12 +1955,62 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return; end if; + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns null. + Hint := Element_Keys.Ceiling (Tree, Item); - if Hint = null then - null; + if Hint /= null then + 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; + + if not Compare then -- Item >= Hint.Element + -- Ceiling returns an element that is equivalent or greater than + -- Item. If Item is "not less than" the element, then by + -- elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree, so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. - elsif Item < Hint.Element.all then if Hint = Node then if Tree.Lock > 0 then raise Program_Error with @@ -1940,12 +2031,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return; end if; - - else - pragma Assert (not (Hint.Element.all < Item)); - raise Program_Error with "attempt to replace existing element"; end if; + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = null), or because Item was less than some element at + -- a different place in the tree (Item < Hint.Element.all). In either + -- case, we remove Node from the tree (without actually deallocating + -- it), and then insert Item into the tree, onto the same Node (so no + -- new node is actually allocated). + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit Local_Insert_With_Hint diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index f92760f..3f25373 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -987,12 +987,15 @@ package body Ada.Containers.Ordered_Sets is B : Natural renames Tree.Busy; L : Natural renames Tree.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin Process (E); + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -1003,7 +1006,7 @@ package body Ada.Containers.Ordered_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then + if Eq then return; end if; end; @@ -1716,17 +1719,55 @@ package body Ada.Containers.Ordered_Sets is return Node; end New_Node; - Hint : Node_Access; - Result : Node_Access; - Inserted : Boolean; + Hint : Node_Access; + Result : Node_Access; + 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 + -- Start of processing for Replace_Element begin - if Item < Node.Element or else Node.Element < Item then - null; + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + 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. - else if Tree.Lock > 0 then raise Program_Error with "attempt to tamper with elements (set is locked)"; @@ -1736,12 +1777,62 @@ package body Ada.Containers.Ordered_Sets is return; end if; + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns null. + Hint := Element_Keys.Ceiling (Tree, Item); - if Hint = null then - null; + if Hint /= null then + 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; + + if not Compare then -- Item >= Hint.Element + -- Ceiling returns an element that is equivalent or greater than + -- Item. If Item is "not less than" the element, then by + -- elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree, so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. - elsif Item < Hint.Element then if Hint = Node then if Tree.Lock > 0 then raise Program_Error with @@ -1751,15 +1842,18 @@ package body Ada.Containers.Ordered_Sets is Node.Element := Item; return; end if; - - else - pragma Assert (not (Hint.Element < Item)); - raise Program_Error with "attempt to replace existing element"; end if; + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = null), or because Item was less than some element at + -- a different place in the tree (Item < Hint.Element). In either case, + -- we remove Node from the tree (without actually deallocating it), and + -- then insert Item into the tree, onto the same Node (so no new node is + -- actually allocated). + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit - Local_Insert_With_Hint + Local_Insert_With_Hint -- use unconditional insert here instead??? (Tree => Tree, Position => Hint, Key => Item, diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb index 713e542..0e27e0a 100644 --- a/gcc/ada/a-crbtgk.adb +++ b/gcc/ada/a-crbtgk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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,10 +38,19 @@ 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; + Y : Node_Access; X : Node_Access; begin + -- 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 @@ -52,18 +61,37 @@ 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; ---------- -- Find -- ---------- - function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access 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; + Y : Node_Access; X : Node_Access; + Result : Node_Access; + begin + -- 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 @@ -75,25 +103,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end loop; if Y = null then - return null; - end if; + Result := null; + + elsif Is_Less_Key_Node (Key, Y) then + Result := null; - if Is_Less_Key_Node (Key, Y) then - return null; + else + Result := Y; end if; - return Y; + B := B - 1; + L := L - 1; + + return Result; + exception + when others => + B := B - 1; + L := L - 1; + raise; end Find; ----------- -- Floor -- ----------- - function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access 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; + Y : Node_Access; X : Node_Access; begin + -- 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 @@ -104,7 +151,15 @@ 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; -------------------------------- @@ -117,8 +172,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Node : out Node_Access; Inserted : out Boolean) is - Y : Node_Access := null; - X : Node_Access := Tree.Root; + 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 -- This is a "conditional" insertion, meaning that the insertion request @@ -136,12 +199,27 @@ 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). - Inserted := True; - while X /= null loop - Y := X; - Inserted := Is_Less_Key_Node (Key, X); - X := (if Inserted then Ops.Left (X) else Ops.Right (X)); - end loop; + begin + B := B + 1; + L := L + 1; + + X := Tree.Root; + Y := null; + Inserted := True; + while X /= null loop + Y := X; + 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 @@ -172,7 +250,22 @@ 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. - if Is_Greater_Key_Node (Key, Node) then + 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 -- Key is strictly greater than Node, which means that Key is not -- equivalent to Node. In this case, the insertion succeeds, and we @@ -201,6 +294,15 @@ 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; + begin -- The purpose of a hint is to avoid a search from the root of -- tree. If we have it hint it means we only need to traverse the @@ -215,9 +317,23 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- done; otherwise the hint was "wrong" and we must search. if Position = null then -- largest - if Tree.Last = null - or else Is_Greater_Key_Node (Key, Tree.Last) - then + begin + B := B + 1; + L := L + 1; + + Compare := Tree.Last = null + or else 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 Insert_Post (Tree, Tree.Last, False, Node); Inserted := True; else @@ -246,28 +362,58 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- then its neighbor must be anterior and so we insert before the -- hint. - if Is_Less_Key_Node (Key, Position) then - declare - Before : constant Node_Access := Ops.Previous (Position); + 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; - begin - if Before = null then - Insert_Post (Tree, Tree.First, True, Node); - Inserted := True; + if Compare then + Test := Ops.Previous (Position); -- "before" - elsif Is_Greater_Key_Node (Key, Before) then - if Ops.Right (Before) = null then - Insert_Post (Tree, Before, False, Node); - else - Insert_Post (Tree, Position, True, Node); - end if; + if Test = null then -- new first node + Insert_Post (Tree, Tree.First, True, Node); - Inserted := True; + Inserted := True; + return; + end if; + 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 + if Ops.Right (Test) = null then + Insert_Post (Tree, Test, False, Node); else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + Insert_Post (Tree, Position, True, Node); end if; - end; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; return; end if; @@ -278,28 +424,58 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- greater than the hint and less than the hint's next neighbor, -- then we're done; otherwise we must search. - if Is_Greater_Key_Node (Key, Position) then - declare - After : constant Node_Access := Ops.Next (Position); + 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; - begin - if After = null then - Insert_Post (Tree, Tree.Last, False, Node); - Inserted := True; + if Compare then + Test := Ops.Next (Position); -- "after" - elsif Is_Less_Key_Node (Key, After) then - if Ops.Right (Position) = null then - Insert_Post (Tree, Position, False, Node); - else - Insert_Post (Tree, After, True, Node); - end if; + if Test = null then -- new last node + Insert_Post (Tree, Tree.Last, False, Node); - Inserted := True; + Inserted := True; + return; + end if; + 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 + if Ops.Right (Position) = null then + Insert_Post (Tree, Position, False, Node); else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + Insert_Post (Tree, Test, True, Node); end if; - end; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; return; end if; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index c8ddcff..adc9ab2 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -626,9 +626,17 @@ 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; + L_Node : Node_Access; R_Node : Node_Access; + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -638,18 +646,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is 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_Node := Left.First; R_Node := Right.First; + Result := True; while L_Node /= null loop if not Is_Equal (L_Node, R_Node) then - return False; + Result := False; + exit; end if; L_Node := Next (L_Node); R_Node := Next (R_Node); end loop; - return True; + 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; ----------------------- diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb index d665713..2710620 100644 --- a/gcc/ada/a-rbtgbo.adb +++ b/gcc/ada/a-rbtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, 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- -- @@ -606,9 +606,17 @@ 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; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + L_Node : Count_Type; R_Node : Count_Type; + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -618,18 +626,43 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is 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_Node := Left.First; R_Node := Right.First; while L_Node /= 0 loop if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - return False; + Result := False; + exit; end if; L_Node := Next (Left, L_Node); R_Node := Next (Right, R_Node); end loop; - return True; + 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; ----------------------- diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb index 2b9b540..700832e 100644 --- a/gcc/ada/a-rbtgso.adb +++ b/gcc/ada/a-rbtgso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -84,8 +84,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ---------------- procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is - Tgt : Node_Access := Target.First; - Src : Node_Access := Source.First; + 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; + + Compare : Integer; begin if Target'Address = Source'Address then @@ -107,19 +115,55 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is "attempt to tamper with cursors (container is busy)"; end if; + Tgt := Target.First; + Src := Source.First; loop if Tgt = null then - return; + exit; end if; if Src = null then - return; + exit; end if; - if Is_Less (Tgt, Src) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + 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 + Compare := 1; + 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 Tgt := Tree_Operations.Next (Tgt); - elsif Is_Less (Src, Tgt) then + elsif Compare > 0 then Src := Tree_Operations.Next (Src); else @@ -137,34 +181,66 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end Difference; function Difference (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type; - - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then - return Tree; -- Empty set + return Tree_Type'(others => <>); -- Empty set end if; if Left.Length = 0 then - return Tree; -- Empty set + return Tree_Type'(others => <>); -- Empty set end if; if Right.Length = 0 then return Copy (Left); end if; - loop - if L_Node = null then - return Tree; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- 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; + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + 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 + if L_Node = null then + exit; + end if; + + if R_Node = null then + while L_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + exit; + end if; - if R_Node = null then - while L_Node /= null loop + if Is_Less (L_Node, R_Node) then Insert_With_Hint (Dst_Tree => Tree, Dst_Hint => null, @@ -173,33 +249,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is L_Node := Tree_Operations.Next (L_Node); - end loop; + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); - return Tree; - end if; + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; - if Is_Less (L_Node, R_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); + BL := BL - 1; + LL := LL - 1; - L_Node := Tree_Operations.Next (L_Node); + BR := BR - 1; + LR := LR - 1; - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); + return Tree; + exception + when others => + BL := BL - 1; + LL := LL - 1; - else - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; + BR := BR - 1; + LR := LR - 1; - exception - when others => - Delete_Tree (Tree.Root); - raise; + Delete_Tree (Tree.Root); + raise; + end; end Difference; ------------------ @@ -210,8 +286,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (Target : in out Tree_Type; Source : Tree_Type) is - Tgt : Node_Access := Target.First; - Src : Node_Access := Source.First; + 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; + + Compare : Integer; begin if Target'Address = Source'Address then @@ -228,10 +312,46 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; + Tgt := Target.First; + Src := Source.First; while Tgt /= null and then Src /= null loop - if Is_Less (Tgt, Src) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + 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 + Compare := 1; + 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 declare X : Node_Access := Tgt; begin @@ -240,7 +360,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Free (X); end; - elsif Is_Less (Src, Tgt) then + elsif Compare > 0 then Src := Tree_Operations.Next (Src); else @@ -261,50 +381,83 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end Intersection; function Intersection (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type; - - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then return Copy (Left); end if; - loop - if L_Node = null then - return Tree; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if R_Node = null then - return Tree; - end if; + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - if Is_Less (L_Node, R_Node) then - L_Node := Tree_Operations.Next (L_Node); + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); + Tree : Tree_Type; - else - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); + L_Node : Node_Access; + R_Node : Node_Access; - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; + Dst_Node : Node_Access; + 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 + if L_Node = null then + exit; + end if; + + if R_Node = null then + exit; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); - exception - when others => - Delete_Tree (Tree.Root); - raise; + else + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + 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; end Intersection; --------------- @@ -324,22 +477,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return False; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare - Subset_Node : Node_Access := Subset.First; - Set_Node : Node_Access := Of_Set.First; + 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; + + 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 - return Subset_Node = null; + Result := Subset_Node = null; + exit; end if; if Subset_Node = null then - return True; + Result := True; + exit; end if; if Is_Less (Subset_Node, Set_Node) then - return False; + Result := False; + exit; end if; if Is_Less (Set_Node, Subset_Node) then @@ -349,6 +524,23 @@ 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; @@ -357,31 +549,72 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ------------- function Overlap (Left, Right : Tree_Type) return Boolean is - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - begin if Left'Address = Right'Address then return Left.Length /= 0; end if; - loop - if L_Node = null - or else R_Node = null - then - return False; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if Is_Less (L_Node, R_Node) then - L_Node := Tree_Operations.Next (L_Node); + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - else - return True; - end if; - end loop; + 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; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + Result := True; + exit; + 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; -------------------------- @@ -392,23 +625,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (Target : in out Tree_Type; Source : Tree_Type) is - Tgt : Node_Access := Target.First; - Src : Node_Access := Source.First; + 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; New_Tgt_Node : Node_Access; pragma Warnings (Off, New_Tgt_Node); - begin - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + Compare : Integer; + begin if Target'Address = Source'Address then Clear (Target); return; end if; + Tgt := Target.First; + Src := Source.First; loop if Tgt = null then while Src /= null loop @@ -428,10 +666,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; - if Is_Less (Tgt, Src) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + 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 + Compare := 1; + 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 Tgt := Tree_Operations.Next (Tgt); - elsif Is_Less (Src, Tgt) then + elsif Compare > 0 then Insert_With_Hint (Dst_Tree => Target, Dst_Hint => Tgt, @@ -455,17 +727,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end Symmetric_Difference; function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type; - - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then - return Tree; -- Empty set + return Tree_Type'(others => <>); -- Empty set end if; if Right.Length = 0 then @@ -476,70 +740,110 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return Copy (Right); end if; - loop - if L_Node = null then - while R_Node /= null loop + -- Per AI05-0022, the container implementation is required to detect + -- 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; + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + 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 + if L_Node = null then + while R_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => R_Node, + Dst_Node => Dst_Node); + R_Node := Tree_Operations.Next (R_Node); + end loop; + + exit; + end if; + + if R_Node = null then + while L_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + exit; + end if; + + if Is_Less (L_Node, R_Node) then Insert_With_Hint (Dst_Tree => Tree, Dst_Hint => null, - Src_Node => R_Node, + Src_Node => L_Node, Dst_Node => Dst_Node); - R_Node := Tree_Operations.Next (R_Node); - end loop; - return Tree; - end if; + L_Node := Tree_Operations.Next (L_Node); - if R_Node = null then - while L_Node /= null loop + elsif Is_Less (R_Node, L_Node) then Insert_With_Hint (Dst_Tree => Tree, Dst_Hint => null, - Src_Node => L_Node, + Src_Node => R_Node, Dst_Node => Dst_Node); - L_Node := Tree_Operations.Next (L_Node); - end loop; + R_Node := Tree_Operations.Next (R_Node); - return Tree; - end if; + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; - if Is_Less (L_Node, R_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); + BL := BL - 1; + LL := LL - 1; - L_Node := Tree_Operations.Next (L_Node); + BR := BR - 1; + LR := LR - 1; - elsif Is_Less (R_Node, L_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => R_Node, - Dst_Node => Dst_Node); + return Tree; + exception + when others => + BL := BL - 1; + LL := LL - 1; - R_Node := Tree_Operations.Next (R_Node); + BR := BR - 1; + LR := LR - 1; - else - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; - - exception - when others => - Delete_Tree (Tree.Root); - raise; + Delete_Tree (Tree.Root); + raise; + end; end Symmetric_Difference; ----------- -- Union -- ----------- - procedure Union (Target : in out Tree_Type; Source : Tree_Type) - is + procedure Union (Target : in out Tree_Type; Source : Tree_Type) is Hint : Node_Access; procedure Process (Node : Node_Access); @@ -555,7 +859,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is begin Insert_With_Hint (Dst_Tree => Target, - Dst_Hint => Hint, + Dst_Hint => Hint, -- use node most recently inserted as hint Src_Node => Node, Dst_Node => Hint); end Process; @@ -567,12 +871,28 @@ 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; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + begin + BS := BS + 1; + LS := LS + 1; + + Iterate (Source); - Iterate (Source); + BS := BS - 1; + LS := LS - 1; + exception + when others => + BS := BS - 1; + LS := LS - 1; + + raise; + end; end Union; function Union (Left, Right : Tree_Type) return Tree_Type is @@ -590,6 +910,12 @@ 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; + Tree : Tree_Type := Copy (Left); Hint : Node_Access; @@ -608,7 +934,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is begin Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Hint, + Dst_Hint => Hint, -- use node most recently inserted as hint Src_Node => Node, Dst_Node => Hint); end Process; @@ -616,15 +942,32 @@ 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); - return Tree; + 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; - end Union; end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c index ac23519..fd85df9 100644 --- a/gcc/ada/cio.c +++ b/gcc/ada/cio.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2013, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -40,6 +40,9 @@ #include "adaint.h" +/* We need L_tmpnam definition */ +#include <stdio.h> + #ifdef __cplusplus extern "C" { #endif @@ -135,7 +138,18 @@ put_char_stderr (int c) char * mktemp (char *template) { +#if !(defined (__RTP__) || defined (VTHREADS)) + static char buf[L_tmpnam]; /* Internal buffer for name */ + + /* If parameter is NULL use internal buffer */ + if (template == NULL) + template = buf; + + __gnat_tmp_name (template); + return template; +#else return tmpnam (NULL); +#endif } #endif diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index cd6d303..1809550 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -134,7 +134,7 @@ package body Debug is -- d.N Add node to all entities -- d.O Dump internal SCO tables -- d.P Previous (non-optimized) handling of length comparisons - -- d.Q + -- d.Q Flow Analysis mode for gnat2why -- d.R Restrictions in ali files in positional form -- d.S Force Optimize_Alignment (Space) -- d.T Force Optimize_Alignment (Time) @@ -648,6 +648,9 @@ package body Debug is -- This is there in case we find a situation where the optimization -- malfunctions, to provide a work around. + -- d.Q Flow Analysis mode for gnat2why. When this flag is given, + -- gnat2why will do flow analysis, and no translation to Why is done. + -- d.R As documented in lib-writ.ads, restrictions in the ali file can -- have two forms, positional and named. The named notation is the -- current preferred form, but the use of this debug switch will force diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 89ffa2b..35d7a9f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4825,10 +4825,146 @@ package body Exp_Ch3 is -- which case the init proc call must be inserted only after the bodies -- of the shared variable procedures have been seen. + function Build_Equivalent_Aggregate return Boolean; + -- If the object has a constrained discriminated type and no initial + -- value, it may be possible to build an equivalent aggregate instead, + -- and prevent an actual call to the initialization procedure. + function Rewrite_As_Renaming return Boolean; -- Indicate whether to rewrite a declaration with initialization into an -- object renaming declaration (see below). + -------------------------------- + -- Build_Equivalent_Aggregate -- + -------------------------------- + + function Build_Equivalent_Aggregate return Boolean is + Aggr : Node_Id; + Comp : Entity_Id; + Discr : Elmt_Id; + Full_Type : Entity_Id; + + begin + Full_Type := Typ; + if Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Full_Type := Full_View (Typ); + end if; + + -- Only perform this transformation if Elaboration_Code is forbidden + -- or undesirable, and if this is a global entity of a constrained + -- record type. + + -- If Initialize_Scalars might be active this transformation cannot + -- be performed either, because it will lead to different semantics + -- or because elaboration code will in fact be created. + + if Ekind (Full_Type) /= E_Record_Subtype + or else not Has_Discriminants (Full_Type) + or else not Is_Constrained (Full_Type) + or else Is_Controlled (Full_Type) + or else Is_Limited_Type (Full_Type) + or else not Restriction_Active (No_Initialize_Scalars) + then + return False; + end if; + + if Ekind (Current_Scope) = E_Package + and then + (Restriction_Active (No_Elaboration_Code) + or else Is_Preelaborated (Current_Scope)) + then + + -- Building a static aggregate is possible if the discriminants + -- have static values and the other components have static + -- defaults or none. + + Discr := First_Elmt (Discriminant_Constraint (Full_Type)); + while Present (Discr) loop + if not Is_OK_Static_Expression (Node (Discr)) then + return False; + end if; + + Next_Elmt (Discr); + end loop; + + -- Check that initialized components are OK, and that non- + -- initialized components do not require a call to their own + -- initialization procedure. + + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Present (Expression (Parent (Comp))) + and then + not Is_OK_Static_Expression (Expression (Parent (Comp))) + then + return False; + + elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then + return False; + + end if; + + Next_Component (Comp); + end loop; + + -- Everything is static, assemble the aggregate, discriminant + -- values first. + + Aggr := + Make_Aggregate (Loc, + Expressions => New_List, + Component_Associations => New_List); + + Discr := First_Elmt (Discriminant_Constraint (Full_Type)); + while Present (Discr) loop + Append_To (Expressions (Aggr), New_Copy (Node (Discr))); + Next_Elmt (Discr); + end loop; + + -- Now collect values of initialized components. + + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Present (Expression (Parent (Comp))) + then + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (New_Occurrence_Of (Comp, Loc)), + Expression => New_Copy_Tree + (Expression (Parent (Comp))))); + end if; + + Next_Component (Comp); + end loop; + + -- Finally, box-initialize remaining components. + + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => Empty)); + Set_Box_Present (Last (Component_Associations (Aggr))); + Set_Expression (N, Aggr); + + if Typ /= Full_Type then + Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type))); + Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr)); + Analyze_And_Resolve (Aggr, Typ); + else + Analyze_And_Resolve (Aggr, Full_Type); + end if; + + return True; + + else + return False; + end if; + end Build_Equivalent_Aggregate; + ------------------------- -- Rewrite_As_Renaming -- ------------------------- @@ -5033,6 +5169,14 @@ package body Exp_Ch3 is (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); return; + -- If type has discriminants, try to build equivalent + -- aggregate using discriminant values from the declaration. + -- This is a useful optimization, in particular if restriction + -- No_Elaboration_Code is active. + + elsif Build_Equivalent_Aggregate then + return; + else Initialization_Warning (Id_Ref); diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index b575eda..a692811 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2013, 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- -- @@ -365,7 +365,6 @@ package body Prj.Attr is -- package Remote "Premote#" & - "LVbuild_slaves#" & "SVroot_dir#" & -- package Stack diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index 0ed8050..9572d68 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -1271,6 +1271,15 @@ package body Prj.Makr is new String'(Get_Name_String (Tmp_File)); end if; + -- On VMS, a file created with Create_Temp_File cannot + -- be used to redirect output. + + if Hostparm.OpenVMS then + Close (FD); + Delete_File (Temp_File_Name.all, Success); + FD := Create_Output_Text_File (Temp_File_Name.all); + end if; + Args (Args'Last) := new String' (Dir_Name & Directory_Separator & diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 492d23a..dee9b90 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -1101,31 +1101,6 @@ The following attributes can be defined in package @code{Remote}: @table @asis -@item @b{Build_Slaves} -@cindex @code{Build_Slaves} - -A list of string referencing the remote build slaves to use for the -compilation phase. The format is: -@code{[protocol://]name.domain[:port]}. - -Where @code{protocol} is one of: - -@table @asis - -@item rsync -@cindex @code{rsync} - -The sources are copied using the external @code{rsync} tool. - -@item file - -The sources are accessed via a shared directory or mount point. - -@end table - -The default port used to communicate with @command{gprslave} is -@code{8484}. - @item @b{Root_Dir}: @cindex @code{Root_Dir} diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 77e2caa..0f0053f 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1205,7 +1205,6 @@ package Snames is Name_Archive_Suffix : constant Name_Id := N + $; Name_Binder : constant Name_Id := N + $; Name_Body_Suffix : constant Name_Id := N + $; - Name_Build_Slaves : constant Name_Id := N + $; Name_Builder : constant Name_Id := N + $; Name_Clean : constant Name_Id := N + $; Name_Compiler : constant Name_Id := N + $; diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads index 54fe8ff..d9d63ea 100644 --- a/gcc/ada/urealp.ads +++ b/gcc/ada/urealp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,7 +46,7 @@ package Urealp is -- use the UR_Eq function). -- A Ureal value represents an arbitrary precision universal real value, - -- stored internally using four components + -- stored internally using four components: -- the numerator (Uint, always non-negative) -- the denominator (Uint, always non-zero, always positive if base = 0) @@ -125,7 +125,7 @@ package Urealp is -- Returns value 10.0 ** 36 function Ureal_M_10_36 return Ureal; - -- Returns value -(10.0 + -- Returns value -10.0 ** 36 ----------------- -- Subprograms -- |