diff options
Diffstat (limited to 'gcc/ada/libgnat/a-convec.adb')
| -rw-r--r-- | gcc/ada/libgnat/a-convec.adb | 70 |
1 files changed, 36 insertions, 34 deletions
diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb index 0dc1d30..197271b 100644 --- a/gcc/ada/libgnat/a-convec.adb +++ b/gcc/ada/libgnat/a-convec.adb @@ -377,6 +377,14 @@ package body Ada.Containers.Vectors is J : Index_Type'Base; -- first index of items that slide down begin + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + + TC_Check (Container.TC); + -- Delete removes items from the vector, the number of which is the -- minimum of the specified Count and the items (if any) that exist from -- Index to Container.Last. There are no constraints on the specified @@ -420,14 +428,6 @@ package body Ada.Containers.Vectors is return; end if; - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete checks the count to determine whether it is - -- being called while the associated callback procedure is executing. - - 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 -- Count_Type'Base as the type for intermediate values. (See function @@ -781,6 +781,8 @@ package body Ada.Containers.Vectors is J : Index_Type'Base; begin + TC_Check (Source.TC); + -- The semantics of Merge changed slightly per AI05-0021. It was -- originally the case that if Target and Source denoted the same -- container object, then the GNAT implementation of Merge did @@ -803,8 +805,6 @@ package body Ada.Containers.Vectors is return; end if; - TC_Check (Source.TC); - Target.Set_Length (Length (Target) + Length (Source)); -- Per AI05-0022, the container implementation is required to detect @@ -861,10 +861,6 @@ package body Ada.Containers.Vectors is "<" => "<"); begin - if Container.Last <= Index_Type'First then - return; - end if; - -- The exception behavior for the vector container must match that -- for the list container, so we check for cursor tampering here -- (which will catch more things) instead of for element tampering @@ -878,6 +874,10 @@ package body Ada.Containers.Vectors is TC_Check (Container.TC); + if Container.Last <= Index_Type'First then + return; + end if; + -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. @@ -933,6 +933,14 @@ package body Ada.Containers.Vectors is Dst : Elements_Access; -- new, expanded internal array begin + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + TC_Check (Container.TC); + if Checks then -- As a precondition on the generic actual Index_Type, the base type -- must include Index_Type'Pred (Index_Type'First); this is the value @@ -1124,14 +1132,6 @@ package body Ada.Containers.Vectors is return; end if; - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on - -- exit. Insert checks the count to determine whether it is being called - -- while the associated callback procedure is executing. - - TC_Check (Container.TC); - -- An internal array has already been allocated, so we must determine -- whether there is enough unused storage for the new items. @@ -1595,6 +1595,14 @@ package body Ada.Containers.Vectors is Dst : Elements_Access; -- new, expanded internal array begin + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + TC_Check (Container.TC); + if Checks then -- As a precondition on the generic actual Index_Type, the base type -- must include Index_Type'Pred (Index_Type'First); this is the value @@ -1784,14 +1792,6 @@ package body Ada.Containers.Vectors is return; end if; - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on - -- exit. Insert checks the count to determine whether it is being called - -- while the associated callback procedure is executing. - - TC_Check (Container.TC); - -- An internal array has already been allocated, so we must determine -- whether there is enough unused storage for the new items. @@ -2446,11 +2446,12 @@ package body Ada.Containers.Vectors is New_Item : Element_Type) is begin + TE_Check (Container.TC); + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - TE_Check (Container.TC); Container.Elements.EA (Index) := New_Item; end Replace_Element; @@ -2460,6 +2461,8 @@ package body Ada.Containers.Vectors is New_Item : Element_Type) is begin + TE_Check (Container.TC); + if Checks then if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; @@ -2472,7 +2475,6 @@ package body Ada.Containers.Vectors is end if; end if; - TE_Check (Container.TC); Container.Elements.EA (Position.Index) := New_Item; end Replace_Element; @@ -2940,6 +2942,8 @@ package body Ada.Containers.Vectors is procedure Swap (Container : in out Vector; I, J : Index_Type) is begin + TE_Check (Container.TC); + if Checks then if I > Container.Last then raise Constraint_Error with "I index is out of range"; @@ -2954,8 +2958,6 @@ package body Ada.Containers.Vectors is return; end if; - TE_Check (Container.TC); - declare EI_Copy : constant Element_Type := Container.Elements.EA (I); begin |