diff options
Diffstat (limited to 'gcc/ada/libgnat/a-convec.adb')
| -rw-r--r-- | gcc/ada/libgnat/a-convec.adb | 102 |
1 files changed, 66 insertions, 36 deletions
diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb index f5e2eb4..c2a0a83 100644 --- a/gcc/ada/libgnat/a-convec.adb +++ b/gcc/ada/libgnat/a-convec.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2019, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2020, 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,8 +31,11 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; -package body Ada.Containers.Vectors is +package body Ada.Containers.Vectors with + SPARK_Mode => Off +is pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); @@ -377,6 +380,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 +431,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 +784,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 +808,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 +864,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 +877,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 +936,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 +1135,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 +1598,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 +1795,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. @@ -2297,6 +2300,31 @@ package body Ada.Containers.Vectors is end return; end Pseudo_Reference; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ------------------- -- Query_Element -- ------------------- @@ -2446,11 +2474,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 +2489,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 +2503,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 +2970,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 +2986,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 |