Skip to content

R
riscv-gcc-1
Commit 2602b64e by Arnaud Charlet
Options

[multiple changes] 

2013-04-11  Robert Dewar  <dewar@adacore.com>

	* stand.ads: Minor reformatting.

2013-04-11  Matthew Heaney  <heaney@adacore.com>

	* a-convec.adb, a-coinve.adb, a-cobove.adb ("="): Increment lock
	counts before entering loop.
	(Find, Find_Index): Ditto.
	(Is_Sorted, Merge, Sort): Ditto.
	(Reverse_Find, Reverse_Find_Index): Ditto.

From-SVN: r197765
parent c8d63650
Showing with 908 additions and 400 deletions
gcc/ada/ChangeLog
2013-04-11 Robert Dewar <dewar@adacore.com>
* stand.ads: Minor reformatting.
2013-04-11 Matthew Heaney <heaney@adacore.com>
* a-convec.adb, a-coinve.adb, a-cobove.adb ("="): Increment lock
counts before entering loop.
(Find, Find_Index): Ditto.
(Is_Sorted, Merge, Sort): Ditto.
(Reverse_Find, Reverse_Find_Index): Ditto.
2013-04-11 Robert Dewar <dewar@adacore.com>
* exp_ch11.ads, exp_ch11.adb (Expand_N_Raise_Expression): New procedure.
* exp_util.adb (Insert_Actions): Add entry for N_Raise_Expression.
* expander.adb: Add call to Expand_N_Raise_Expression.
......
gcc/ada/a-cobove.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- --
......@@ -112,8 +112,8 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "new length is out of range";
end if;
-- It is now safe compute the length of the new vector, without fear of
-- overflow.
-- It is now safe to compute the length of the new vector, without fear
-- of overflow.
N := LN + RN;
......@@ -122,6 +122,7 @@ package body Ada.Containers.Bounded_Vectors is
-- Count_Type'Base as the type for intermediate values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then
-- determine whether it lies in the range of the index (sub)type.
......@@ -150,6 +151,7 @@ package body Ada.Containers.Bounded_Vectors is
end if;
elsif Index_Type'First <= 0 then
-- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of length.
......@@ -280,6 +282,14 @@ package body Ada.Containers.Bounded_Vectors is
---------
overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
begin
if Left'Address = Right'Address then
return True;
......@@ -289,13 +299,40 @@ package body Ada.Containers.Bounded_Vectors 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;
Result := True;
for J in Count_Type range 1 .. Left.Length loop
if Left.Elements (J) /= Right.Elements (J) then
return False;
Result := False;
exit;
end if;
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 "=";
------------
......@@ -543,7 +580,6 @@ package body Ada.Containers.Bounded_Vectors is
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
else
Count2 := Count_Type'Base (Old_Last - Index + 1);
end if;
......@@ -567,7 +603,6 @@ package body Ada.Containers.Bounded_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Off := Count_Type'Base (Index - Index_Type'First);
New_Last := Old_Last - Index_Type'Base (Count);
else
Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
......@@ -579,7 +614,6 @@ package body Ada.Containers.Bounded_Vectors is
declare
EA : Elements_Array renames Container.Elements;
Idx : constant Count_Type := EA'First + Off;
begin
EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
Container.Last := New_Last;
......@@ -621,14 +655,14 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Count = 0 then
return;
end if;
if Count >= Length (Container) then
elsif Count >= Length (Container) then
Clear (Container);
return;
end if;
else
Delete (Container, Index_Type'First, Count);
end if;
end Delete_First;
-----------------
......@@ -738,13 +772,42 @@ package body Ada.Containers.Bounded_Vectors is
end if;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop
if Container.Elements (To_Array_Index (J)) = Item then
return (Container'Unrestricted_Access, J);
Result := J;
exit;
end if;
end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Find;
----------------
......@@ -756,14 +819,36 @@ package body Ada.Containers.Bounded_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index
is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in Index .. Container.Last loop
if Container.Elements (To_Array_Index (Indx)) = Item then
return Indx;
Result := Indx;
exit;
end if;
end loop;
return No_Index;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find_Index;
-----------
......@@ -841,17 +926,40 @@ package body Ada.Containers.Bounded_Vectors is
return True;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
EA : Elements_Array renames Container.Elements;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
begin
B := B + 1;
L := L + 1;
Result := True;
for J in 1 .. Container.Length - 1 loop
if EA (J + 1) < EA (J) then
return False;
Result := False;
exit;
end if;
end loop;
end;
return True;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Is_Sorted;
-----------
......@@ -862,7 +970,6 @@ package body Ada.Containers.Bounded_Vectors is
I, J : Count_Type;
begin
-- 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
......@@ -893,21 +1000,35 @@ package body Ada.Containers.Bounded_Vectors is
I := Target.Length;
Target.Set_Length (I + Source.Length);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
TA : Elements_Array renames Target.Elements;
SA : Elements_Array renames Source.Elements;
TB : Natural renames Target.Busy;
TL : Natural renames Target.Lock;
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Length;
while not Source.Is_Empty loop
pragma Assert (Source.Length <= 1
or else not (SA (Source.Length) <
SA (Source.Length - 1)));
or else not (SA (Source.Length) < SA (Source.Length - 1)));
if I = 0 then
TA (1 .. J) := SA (1 .. Source.Length);
Source.Last := No_Index;
return;
exit;
end if;
pragma Assert (I <= 1
......@@ -924,6 +1045,22 @@ package body Ada.Containers.Bounded_Vectors is
J := J - 1;
end loop;
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
exception
when others =>
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
raise;
end;
end Merge;
......@@ -960,7 +1097,28 @@ package body Ada.Containers.Bounded_Vectors is
"attempt to tamper with cursors (vector is busy)";
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
Sort (Container.Elements (1 .. Container.Length));
B := B - 1;
L := L - 1;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Sort;
end Generic_Sorting;
......@@ -1056,10 +1214,12 @@ package body Ada.Containers.Bounded_Vectors is
-- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is
-- less than 0, so it is safe to compute the following sum without
-- fear of overflow.
......@@ -1067,6 +1227,7 @@ package body Ada.Containers.Bounded_Vectors is
Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
......@@ -1091,6 +1252,7 @@ package body Ada.Containers.Bounded_Vectors is
end if;
elsif Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is less
-- than 0, so it is safe to compute the following sum without fear of
-- overflow.
......@@ -1098,6 +1260,7 @@ package body Ada.Containers.Bounded_Vectors is
J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the maximum
-- number of items that are allowed.
......@@ -1151,6 +1314,7 @@ package body Ada.Containers.Bounded_Vectors is
J := To_Array_Index (Before);
if Before > Container.Last then
-- The new items are being appended to the vector, so no
-- sliding of existing elements is required.
......@@ -1508,10 +1672,12 @@ package body Ada.Containers.Bounded_Vectors is
-- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is
-- less than 0, so it is safe to compute the following sum without
-- fear of overflow.
......@@ -1519,6 +1685,7 @@ package body Ada.Containers.Bounded_Vectors is
Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
......@@ -1543,6 +1710,7 @@ package body Ada.Containers.Bounded_Vectors is
end if;
elsif Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is less
-- than 0, so it is safe to compute the following sum without fear of
-- overflow.
......@@ -1550,6 +1718,7 @@ package body Ada.Containers.Bounded_Vectors is
J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the maximum
-- number of items that are allowed.
......@@ -1608,6 +1777,7 @@ package body Ada.Containers.Bounded_Vectors is
-- unused storage for the new items.
if Before <= Container.Last then
-- The space is being inserted before some existing elements,
-- so we must slide the existing elements up to their new home.
......@@ -1927,36 +2097,30 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Index < Position.Container.Last then
elsif Position.Index < Position.Container.Last then
return (Position.Container, Position.Index + 1);
end if;
else
return No_Element;
end if;
end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
end if;
else
return Next (Position);
end if;
end Next;
procedure Next (Position : in out Cursor) is
begin
if Position.Container = null then
return;
end if;
if Position.Index < Position.Container.Last then
elsif Position.Index < Position.Container.Last then
Position.Index := Position.Index + 1;
else
Position := No_Element;
......@@ -1992,9 +2156,7 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
return;
end if;
if Position.Index > Index_Type'First then
elsif Position.Index > Index_Type'First then
Position.Index := Position.Index - 1;
else
Position := No_Element;
......@@ -2005,27 +2167,23 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Index > Index_Type'First then
elsif Position.Index > Index_Type'First then
return (Position.Container, Position.Index - 1);
end if;
else
return No_Element;
end if;
end Previous;
function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
end if;
else
return Previous (Position);
end if;
end Previous;
-------------------
......@@ -2069,9 +2227,9 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
else
Query_Element (Position.Container.all, Position.Index, Process);
end if;
end Query_Element;
----------
......@@ -2146,9 +2304,9 @@ package body Ada.Containers.Bounded_Vectors is
declare
A : Elements_Array renames Container.Elements;
I : constant Count_Type := To_Array_Index (Position.Index);
J : constant Count_Type := To_Array_Index (Position.Index);
begin
return (Element => A (I)'Access);
return (Element => A (J)'Access);
end;
end Reference;
......@@ -2163,9 +2321,9 @@ package body Ada.Containers.Bounded_Vectors is
declare
A : Elements_Array renames Container.Elements;
I : constant Count_Type := To_Array_Index (Index);
J : constant Count_Type := To_Array_Index (Index);
begin
return (Element => A (I)'Access);
return (Element => A (J)'Access);
end;
end Reference;
......@@ -2181,14 +2339,12 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
if Container.Lock > 0 then
elsif Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
else
Container.Elements (To_Array_Index (Index)) := New_Item;
end if;
end Replace_Element;
procedure Replace_Element
......@@ -2199,22 +2355,20 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then
elsif Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
if Container.Lock > 0 then
elsif Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
else
Container.Elements (To_Array_Index (Position.Index)) := New_Item;
end if;
end Replace_Element;
----------------------
......@@ -2300,13 +2454,41 @@ package body Ada.Containers.Bounded_Vectors is
then Container.Last
else Position.Index);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements (To_Array_Index (Indx)) = Item then
return (Container'Unrestricted_Access, Indx);
Result := Indx;
exit;
end if;
end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Reverse_Find;
------------------------
......@@ -2318,17 +2500,39 @@ package body Ada.Containers.Bounded_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index
is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index);
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements (To_Array_Index (Indx)) = Item then
return Indx;
Result := Indx;
exit;
end if;
end loop;
return No_Index;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Reverse_Find_Index;
---------------------
......@@ -2375,10 +2579,8 @@ package body Ada.Containers.Bounded_Vectors is
if Count >= 0 then
Container.Delete_Last (Count);
elsif Container.Last >= Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
else
Container.Insert_Space (Container.Last + 1, -Count);
end if;
......@@ -2451,11 +2653,11 @@ package body Ada.Containers.Bounded_Vectors is
-- hence we also know that
-- Index - Index_Type'First >= 0
-- The issue is that even though 0 is guaranteed to be a value
-- in the type Index_Type'Base, there's no guarantee that the
-- difference is a value in that type. To prevent overflow we
-- use the wider of Count_Type'Base and Index_Type'Base to
-- perform intermediate calculations.
-- The issue is that even though 0 is guaranteed to be a value in
-- the type Index_Type'Base, there's no guarantee that the difference
-- is a value in that type. To prevent overflow we use the wider
-- of Count_Type'Base and Index_Type'Base to perform intermediate
-- calculations.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Offset := Count_Type'Base (Index - Index_Type'First);
......
gcc/ada/a-coinve.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- --
......@@ -117,7 +117,6 @@ package body Ada.Containers.Indefinite_Vectors is
return (Controlled with Elements, Right.Last, 0, 0);
end;
end if;
if RN = 0 then
......@@ -243,7 +242,6 @@ package body Ada.Containers.Indefinite_Vectors is
declare
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
......@@ -514,6 +512,14 @@ package body Ada.Containers.Indefinite_Vectors is
---------
overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
begin
if Left'Address = Right'Address then
return True;
......@@ -523,21 +529,49 @@ package body Ada.Containers.Indefinite_Vectors 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;
Result := True;
for J in Index_Type'First .. Left.Last loop
if Left.Elements.EA (J) = null then
if Right.Elements.EA (J) /= null then
return False;
Result := False;
exit;
end if;
elsif Right.Elements.EA (J) = null then
return False;
Result := False;
exit;
elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
return False;
Result := False;
exit;
end if;
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 "=";
------------
......@@ -564,12 +598,12 @@ package body Ada.Containers.Indefinite_Vectors is
Container.Elements := new Elements_Type (L);
for I in E'Range loop
if E (I) /= null then
Container.Elements.EA (I) := new Element_Type'(E (I).all);
for J in E'Range loop
if E (J) /= null then
Container.Elements.EA (J) := new Element_Type'(E (J).all);
end if;
Container.Last := I;
Container.Last := J;
end loop;
end;
end Adjust;
......@@ -596,16 +630,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Is_Empty (New_Item) then
return;
end if;
if Container.Last = Index_Type'Last then
elsif Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
else
Insert (Container, Container.Last + 1, New_Item);
end if;
Insert
(Container,
Container.Last + 1,
New_Item);
end Append;
procedure Append
......@@ -616,17 +645,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Count = 0 then
return;
end if;
if Container.Last = Index_Type'Last then
elsif Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
else
Insert (Container, Container.Last + 1, New_Item, Count);
end if;
Insert
(Container,
Container.Last + 1,
New_Item,
Count);
end Append;
------------
......@@ -637,10 +660,10 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Target'Address = Source'Address then
return;
end if;
else
Target.Clear;
Target.Append (Source);
end if;
end Assign;
--------------
......@@ -651,9 +674,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Container.Elements = null then
return 0;
end if;
else
return Container.Elements.EA'Length;
end if;
end Capacity;
-----------
......@@ -665,8 +688,8 @@ package body Ada.Containers.Indefinite_Vectors is
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
else
while Container.Last >= Index_Type'First loop
declare
X : Element_Access := Container.Elements.EA (Container.Last);
......@@ -676,6 +699,7 @@ package body Ada.Containers.Indefinite_Vectors is
Free (X);
end;
end loop;
end if;
end Clear;
------------------------
......@@ -840,10 +864,10 @@ package body Ada.Containers.Indefinite_Vectors is
if Index > Old_Last then
if Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)";
end if;
else
return;
end if;
end if;
-- Here and elsewhere we treat deleting 0 items from the container as a
-- no-op, even when the container is busy, so we simply return.
......@@ -934,7 +958,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := Old_Last - Index_Type'Base (Count);
J := Index + Index_Type'Base (Count);
else
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
J := Index_Type'Base (Count_Type'Base (Index) + Count);
......@@ -987,19 +1010,17 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then
elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
end if;
else
Delete (Container, Position.Index, Count);
Position := No_Element;
end if;
end Delete;
------------------
......@@ -1013,14 +1034,14 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Count = 0 then
return;
end if;
if Count >= Length (Container) then
elsif Count >= Length (Container) then
Clear (Container);
return;
end if;
else
Delete (Container, Index_Type'First, Count);
end if;
end Delete_First;
-----------------
......@@ -1110,13 +1131,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare
EA : constant Element_Access := Container.Elements.EA (Index);
begin
if EA = null then
raise Constraint_Error with "element is empty";
end if;
else
return EA.all;
end if;
end;
end Element;
......@@ -1133,13 +1153,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare
EA : constant Element_Access :=
Position.Container.Elements.EA (Position.Index);
begin
if EA = null then
raise Constraint_Error with "element is empty";
end if;
else
return EA.all;
end if;
end;
end Element;
......@@ -1201,15 +1220,44 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) /= null
and then Container.Elements.EA (J).all = Item
then
return (Container'Unrestricted_Access, J);
Result := J;
exit;
end if;
end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Find;
----------------
......@@ -1221,16 +1269,38 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index
is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in Index .. Container.Last loop
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
return Indx;
Result := Indx;
exit;
end if;
end loop;
return No_Index;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find_Index;
-----------
......@@ -1282,13 +1352,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare
EA : constant Element_Access :=
Container.Elements.EA (Index_Type'First);
begin
if EA = null then
raise Constraint_Error with "first element is empty";
end if;
else
return EA.all;
end if;
end;
end First_Element;
......@@ -1340,17 +1409,40 @@ package body Ada.Containers.Indefinite_Vectors is
return True;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
E : Elements_Array renames Container.Elements.EA;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
begin
B := B + 1;
L := L + 1;
Result := True;
for I in Index_Type'First .. Container.Last - 1 loop
if Is_Less (E (I + 1), E (I)) then
return False;
Result := False;
exit;
end if;
end loop;
end;
return True;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Is_Sorted;
-----------
......@@ -1361,7 +1453,6 @@ package body Ada.Containers.Indefinite_Vectors is
I, J : Index_Type'Base;
begin
-- 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
......@@ -1392,37 +1483,53 @@ package body Ada.Containers.Indefinite_Vectors is
I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source));
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
TA : Elements_Array renames Target.Elements.EA;
SA : Elements_Array renames Source.Elements.EA;
TB : Natural renames Target.Busy;
TL : Natural renames Target.Lock;
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Last; -- new value (after Set_Length)
while Source.Last >= Index_Type'First loop
pragma Assert
(Source.Last <= Index_Type'First
or else not (Is_Less
(Source.Elements.EA (Source.Last),
Source.Elements.EA (Source.Last - 1))));
or else not (Is_Less (SA (Source.Last),
SA (Source.Last - 1))));
if I < Index_Type'First then
declare
Src : Elements_Array renames
Source.Elements.EA (Index_Type'First .. Source.Last);
SA (Index_Type'First .. Source.Last);
begin
Target.Elements.EA (Index_Type'First .. J) := Src;
TA (Index_Type'First .. J) := Src;
Src := (others => null);
end;
Source.Last := No_Index;
return;
exit;
end if;
pragma Assert
(I <= Index_Type'First
or else not (Is_Less
(Target.Elements.EA (I),
Target.Elements.EA (I - 1))));
or else not (Is_Less (TA (I), TA (I - 1))));
declare
Src : Element_Access renames Source.Elements.EA (Source.Last);
Tgt : Element_Access renames Target.Elements.EA (I);
Src : Element_Access renames SA (Source.Last);
Tgt : Element_Access renames TA (I);
begin
if Is_Less (Src, Tgt) then
......@@ -1439,6 +1546,23 @@ package body Ada.Containers.Indefinite_Vectors is
J := J - 1;
end loop;
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
exception
when others =>
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
raise;
end;
end Merge;
----------
......@@ -1475,7 +1599,28 @@ package body Ada.Containers.Indefinite_Vectors is
"attempt to tamper with cursors (vector is busy)";
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
B := B - 1;
L := L - 1;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Sort;
end Generic_Sorting;
......@@ -1488,9 +1633,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return False;
end if;
else
return Position.Index <= Position.Container.Last;
end if;
end Has_Element;
------------
......@@ -1663,7 +1808,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length);
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if;
......@@ -1859,7 +2003,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else
Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
......@@ -1888,9 +2031,8 @@ package body Ada.Containers.Indefinite_Vectors is
-- The new items are being appended to the vector, so no
-- sliding of existing elements is required.
-- We have copied the elements from to the old, source array to
-- the new, destination array, so we can now deallocate the old
-- array.
-- We have copied the elements from to the old source array to the
-- new destination array, so we can now deallocate the old array.
Container.Elements := Dst;
Free (Src);
......@@ -1899,11 +2041,11 @@ package body Ada.Containers.Indefinite_Vectors is
for Idx in Before .. New_Last loop
-- In order to preserve container invariants, we always
-- attempt the element allocation first, before setting the
-- Last index value, in case the allocation fails (either
-- because there is no storage available, or because element
-- initialization fails).
-- In order to preserve container invariants, we always attempt
-- the element allocation first, before setting the Last index
-- value, in case the allocation fails (either because there
-- is no storage available, or because element initialization
-- fails).
declare
-- The element allocator may need an accessibility check in
......@@ -1928,24 +2070,21 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
-- We have copied the elements from to the old, source array to
-- the new, destination array, so we can now deallocate the old
-- array.
-- We have copied the elements from to the old source array to the
-- new destination array, so we can now deallocate the old array.
Container.Elements := Dst;
Container.Last := New_Last;
Free (Src);
-- The new array has a range in the middle containing null access
-- values. We now fill in that partition of the array with the new
-- items.
-- values. Fill in that partition of the array with the new items.
for Idx in Before .. Index - 1 loop
......@@ -2081,7 +2220,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
J := Before + Index_Type'Base (N);
else
J := Index_Type'Base (Count_Type'Base (Before) + N);
end if;
......@@ -2105,7 +2243,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Index := J - Index_Type'Base (Src'Length);
else
Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
end if;
......@@ -2138,9 +2275,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -2172,9 +2307,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
if Is_Empty (New_Item) then
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
......@@ -2183,9 +2316,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -2221,9 +2352,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -2266,9 +2395,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -2330,9 +2457,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
if Before > Container.Last
and then Before > Container.Last + 1
then
if Before > Container.Last and then Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
......@@ -2453,7 +2578,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length);
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if;
......@@ -2490,7 +2614,8 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
if New_Length <= Container.Elements.EA'Length then
-- In this case, we're inserting elements into a vector that has
-- In this case, we are inserting elements into a vector that has
-- already allocated an internal array, and the existing array has
-- enough unused storage for the new items.
......@@ -2501,13 +2626,12 @@ package body Ada.Containers.Indefinite_Vectors is
if Before <= Container.Last then
-- The new space is being inserted before some existing
-- elements, so we must slide the existing elements up to their
-- new home. We use the wider of Index_Type'Base and
-- elements, so we must slide the existing elements up to
-- their new home. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate index values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
......@@ -2554,7 +2678,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else
Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
......@@ -2585,7 +2708,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
......@@ -2619,9 +2741,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
if Count = 0 then
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
......@@ -2811,13 +2931,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare
EA : constant Element_Access :=
Container.Elements.EA (Container.Last);
begin
if EA = null then
raise Constraint_Error with "last element is empty";
end if;
else
return EA.all;
end if;
end;
end Last_Element;
......@@ -2903,36 +3022,30 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Index < Position.Container.Last then
elsif Position.Index < Position.Container.Last then
return (Position.Container, Position.Index + 1);
end if;
else
return No_Element;
end if;
end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
end if;
else
return Next (Position);
end if;
end Next;
procedure Next (Position : in out Cursor) is
begin
if Position.Container = null then
return;
end if;
if Position.Index < Position.Container.Last then
elsif Position.Index < Position.Container.Last then
Position.Index := Position.Index + 1;
else
Position := No_Element;
......@@ -2954,10 +3067,7 @@ package body Ada.Containers.Indefinite_Vectors is
Count : Count_Type := 1)
is
begin
Insert (Container,
Index_Type'First,
New_Item,
Count);
Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
--------------
......@@ -2968,9 +3078,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return;
end if;
if Position.Index > Index_Type'First then
elsif Position.Index > Index_Type'First then
Position.Index := Position.Index - 1;
else
Position := No_Element;
......@@ -2981,27 +3089,23 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Index > Index_Type'First then
elsif Position.Index > Index_Type'First then
return (Position.Container, Position.Index - 1);
end if;
else
return No_Element;
end if;
end Previous;
function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
end if;
else
return Previous (Position);
end if;
end Previous;
-------------------
......@@ -3049,9 +3153,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
else
Query_Element (Position.Container.all, Position.Index, Process);
end if;
end Query_Element;
----------
......@@ -3064,7 +3168,6 @@ package body Ada.Containers.Indefinite_Vectors is
is
Length : Count_Type'Base;
Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
B : Boolean;
begin
......@@ -3616,23 +3719,50 @@ package body Ada.Containers.Indefinite_Vectors is
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Container = null
or else Position.Index > Container.Last
then
if Position.Container = null or else Position.Index > Container.Last then
Last := Container.Last;
else
Last := Position.Index;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
return (Container'Unrestricted_Access, Indx);
Result := Indx;
exit;
end if;
end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Reverse_Find;
------------------------
......@@ -3644,18 +3774,41 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index
is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Last : constant Index_Type'Base :=
(if Index > Container.Last then Container.Last else Index);
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
return Indx;
Result := Indx;
exit;
end if;
end loop;
return No_Index;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Reverse_Find_Index;
---------------------
......@@ -3800,13 +3953,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return No_Index;
end if;
if Position.Index <= Position.Container.Last then
elsif Position.Index <= Position.Container.Last then
return Position.Index;
end if;
else
return No_Index;
end if;
end To_Index;
---------------
......@@ -4072,13 +4223,13 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
else
Update_Element (Container, Position.Index, Process);
end if;
end Update_Element;
-----------
......
gcc/ada/a-convec.adb
......@@ -86,10 +86,8 @@ package body Ada.Containers.Vectors is
declare
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
new Elements_Type'(Right.Last, RE);
begin
return (Controlled with Elements, Right.Last, 0, 0);
end;
......@@ -99,10 +97,8 @@ package body Ada.Containers.Vectors is
declare
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access :=
new Elements_Type'(Left.Last, LE);
begin
return (Controlled with Elements, Left.Last, 0, 0);
end;
......@@ -199,13 +195,10 @@ package body Ada.Containers.Vectors is
declare
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
new Elements_Type'(Last, LE & RE);
begin
return (Controlled with Elements, Last, 0, 0);
end;
......@@ -248,13 +241,10 @@ package body Ada.Containers.Vectors is
declare
Last : constant Index_Type := Left.Last + 1;
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access :=
new Elements_Type'(Last => Last, EA => LE & Right);
begin
return (Controlled with Elements, Last, 0, 0);
end;
......@@ -275,7 +265,6 @@ package body Ada.Containers.Vectors is
new Elements_Type'
(Last => Index_Type'First,
EA => (others => Left));
begin
return (Controlled with Elements, Index_Type'First, 0, 0);
end;
......@@ -346,6 +335,14 @@ package body Ada.Containers.Vectors is
---------
overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
begin
if Left'Address = Right'Address then
return True;
......@@ -355,13 +352,40 @@ package body Ada.Containers.Vectors 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;
Result := True;
for J in Index_Type range Index_Type'First .. Left.Last loop
if Left.Elements.EA (J) /= Right.Elements.EA (J) then
return False;
Result := False;
exit;
end if;
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 "=";
------------
......@@ -418,16 +442,11 @@ package body Ada.Containers.Vectors is
begin
if Is_Empty (New_Item) then
return;
end if;
if Container.Last = Index_Type'Last then
elsif Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
else
Insert (Container, Container.Last + 1, New_Item);
end if;
Insert
(Container,
Container.Last + 1,
New_Item);
end Append;
procedure Append
......@@ -438,17 +457,11 @@ package body Ada.Containers.Vectors is
begin
if Count = 0 then
return;
end if;
if Container.Last = Index_Type'Last then
elsif Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
else
Insert (Container, Container.Last + 1, New_Item, Count);
end if;
Insert
(Container,
Container.Last + 1,
New_Item,
Count);
end Append;
------------
......@@ -459,10 +472,10 @@ package body Ada.Containers.Vectors is
begin
if Target'Address = Source'Address then
return;
end if;
else
Target.Clear;
Target.Append (Source);
end if;
end Assign;
--------------
......@@ -638,10 +651,10 @@ package body Ada.Containers.Vectors is
if Index > Old_Last then
if Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)";
end if;
else
return;
end if;
end if;
-- Here and elsewhere we treat deleting 0 items from the container as a
-- no-op, even when the container is busy, so we simply return.
......@@ -668,7 +681,6 @@ package body Ada.Containers.Vectors is
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
else
Count2 := Count_Type'Base (Old_Last - Index + 1);
end if;
......@@ -694,7 +706,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := Old_Last - Index_Type'Base (Count);
J := Index + Index_Type'Base (Count);
else
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
J := Index_Type'Base (Count_Type'Base (Index) + Count);
......@@ -708,7 +719,6 @@ package body Ada.Containers.Vectors is
declare
EA : Elements_Array renames Container.Elements.EA;
begin
EA (Index .. New_Last) := EA (J .. Old_Last);
Container.Last := New_Last;
......@@ -725,18 +735,17 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then
elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
end if;
else
Delete (Container, Position.Index, Count);
Position := No_Element;
end if;
end Delete;
------------------
......@@ -750,14 +759,14 @@ package body Ada.Containers.Vectors is
begin
if Count = 0 then
return;
end if;
if Count >= Length (Container) then
elsif Count >= Length (Container) then
Clear (Container);
return;
end if;
else
Delete (Container, Index_Type'First, Count);
end if;
end Delete_First;
-----------------
......@@ -823,9 +832,9 @@ package body Ada.Containers.Vectors is
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
else
return Container.Elements.EA (Index);
end if;
end Element;
function Element (Position : Cursor) return Element_Type is
......@@ -850,11 +859,12 @@ package body Ada.Containers.Vectors is
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
else
Container.Elements := null;
Container.Last := No_Index;
Free (X);
end if;
end Finalize;
procedure Finalize (Object : in out Iterator) is
......@@ -899,13 +909,42 @@ package body Ada.Containers.Vectors is
end if;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) = Item then
return (Container'Unrestricted_Access, J);
Result := J;
exit;
end if;
end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Find;
----------------
......@@ -917,14 +956,36 @@ package body Ada.Containers.Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index
is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in Index .. Container.Last loop
if Container.Elements.EA (Indx) = Item then
return Indx;
Result := Indx;
exit;
end if;
end loop;
return No_Index;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find_Index;
-----------
......@@ -1002,17 +1063,40 @@ package body Ada.Containers.Vectors is
return True;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
EA : Elements_Array renames Container.Elements.EA;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
begin
B := B + 1;
L := L + 1;
Result := True;
for J in Index_Type'First .. Container.Last - 1 loop
if EA (J + 1) < EA (J) then
return False;
Result := False;
exit;
end if;
end loop;
end;
return True;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Is_Sorted;
-----------
......@@ -1053,11 +1137,26 @@ package body Ada.Containers.Vectors is
Target.Set_Length (Length (Target) + Length (Source));
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
TA : Elements_Array renames Target.Elements.EA;
SA : Elements_Array renames Source.Elements.EA;
TB : Natural renames Target.Busy;
TL : Natural renames Target.Lock;
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Last;
while Source.Last >= Index_Type'First loop
pragma Assert (Source.Last <= Index_Type'First
......@@ -1069,7 +1168,7 @@ package body Ada.Containers.Vectors is
SA (Index_Type'First .. Source.Last);
Source.Last := No_Index;
return;
exit;
end if;
pragma Assert (I <= Index_Type'First
......@@ -1086,6 +1185,22 @@ package body Ada.Containers.Vectors is
J := J - 1;
end loop;
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
exception
when others =>
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
raise;
end;
end Merge;
......@@ -1122,7 +1237,28 @@ package body Ada.Containers.Vectors is
"attempt to tamper with cursors (vector is busy)";
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
B := B - 1;
L := L - 1;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Sort;
end Generic_Sorting;
......@@ -1182,9 +1318,7 @@ package body Ada.Containers.Vectors is
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
if Before > Container.Last
and then Before > Container.Last + 1
then
if Before > Container.Last and then Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
......@@ -1374,7 +1508,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
......@@ -1402,9 +1535,9 @@ package body Ada.Containers.Vectors is
if New_Capacity > Count_Type'Last / 2 then
New_Capacity := Count_Type'Last;
exit;
end if;
else
New_Capacity := 2 * New_Capacity;
end if;
end loop;
if New_Capacity > Max_Length then
......@@ -1421,7 +1554,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else
Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
......@@ -1455,7 +1587,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
......@@ -1475,6 +1606,7 @@ package body Ada.Containers.Vectors is
declare
X : Elements_Access := Container.Elements;
begin
-- We first isolate the old internal array, removing it from the
-- container and replacing it with the new internal array, before we
......@@ -1518,7 +1650,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
J := (Before - 1) + Index_Type'Base (N);
else
J := Index_Type'Base (Count_Type'Base (Before - 1) + N);
end if;
......@@ -1562,7 +1693,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
K := L + Index_Type'Base (Src'Length);
else
K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
end if;
......@@ -1606,7 +1736,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
K := F - Index_Type'Base (Src'Length);
else
K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
end if;
......@@ -1633,9 +1762,7 @@ package body Ada.Containers.Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -1666,9 +1793,7 @@ package body Ada.Containers.Vectors is
end if;
if Is_Empty (New_Item) then
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
......@@ -1677,9 +1802,7 @@ package body Ada.Containers.Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -1715,9 +1838,7 @@ package body Ada.Containers.Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -1749,9 +1870,7 @@ package body Ada.Containers.Vectors is
end if;
if Count = 0 then
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
......@@ -1760,9 +1879,7 @@ package body Ada.Containers.Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -1799,7 +1916,6 @@ package body Ada.Containers.Vectors is
is
New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item);
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
......@@ -1849,9 +1965,7 @@ package body Ada.Containers.Vectors is
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
if Before > Container.Last
and then Before > Container.Last + 1
then
if Before > Container.Last and then Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
......@@ -1973,7 +2087,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length);
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if;
......@@ -2081,7 +2194,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else
Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
......@@ -2113,7 +2225,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
......@@ -2166,9 +2277,7 @@ package body Ada.Containers.Vectors is
end if;
if Count = 0 then
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
......@@ -2177,9 +2286,7 @@ package body Ada.Containers.Vectors is
return;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
......@@ -2455,14 +2562,12 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
end if;
else
return Next (Position);
end if;
end Next;
procedure Next (Position : in out Cursor) is
......@@ -2491,10 +2596,7 @@ package body Ada.Containers.Vectors is
Count : Count_Type := 1)
is
begin
Insert (Container,
Index_Type'First,
New_Item,
Count);
Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
--------------
......@@ -2516,14 +2618,12 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
end if;
else
return Previous (Position);
end if;
end Previous;
procedure Previous (Position : in out Cursor) is
......@@ -2578,9 +2678,9 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
else
Query_Element (Position.Container.all, Position.Index, Process);
end if;
end Query_Element;
----------
......@@ -2677,6 +2777,7 @@ package body Ada.Containers.Vectors is
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
else
declare
C : Vector renames Container'Unrestricted_Access.all;
......@@ -2706,14 +2807,12 @@ package body Ada.Containers.Vectors is
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
if Container.Lock > 0 then
elsif Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
else
Container.Elements.EA (Index) := New_Item;
end if;
end Replace_Element;
procedure Replace_Element
......@@ -2724,22 +2823,21 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then
elsif Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
else
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
Container.Elements.EA (Position.Index) := New_Item;
end if;
end Replace_Element;
----------------------
......@@ -3126,13 +3224,42 @@ package body Ada.Containers.Vectors is
then Container.Last
else Position.Index);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = Item then
return (Container'Unrestricted_Access, Indx);
Result := Indx;
exit;
end if;
end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Reverse_Find;
------------------------
......@@ -3144,17 +3271,39 @@ package body Ada.Containers.Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index
is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index);
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = Item then
return Indx;
Result := Indx;
exit;
end if;
end loop;
return No_Index;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Reverse_Find_Index;
---------------------
......@@ -3245,21 +3394,19 @@ package body Ada.Containers.Vectors is
begin
if I.Container = null then
raise Constraint_Error with "I cursor has no element";
end if;
if J.Container = null then
elsif J.Container = null then
raise Constraint_Error with "J cursor has no element";
end if;
if I.Container /= Container'Unrestricted_Access then
elsif I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor denotes wrong container";
end if;
if J.Container /= Container'Unrestricted_Access then
elsif J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor denotes wrong container";
end if;
else
Swap (Container, I.Index, J.Index);
end if;
end Swap;
---------------
......@@ -3286,13 +3433,11 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
return No_Index;
end if;
if Position.Index <= Position.Container.Last then
elsif Position.Index <= Position.Container.Last then
return Position.Index;
end if;
else
return No_Index;
end if;
end To_Index;
---------------
......
gcc/ada/stand.ads
......@@ -364,23 +364,21 @@ package Stand is
Any_Type : Entity_Id;
-- Used to represent some unknown type. Any_Type is the type of an
-- unresolved operator, and it is the type of a node where a type error
-- has been detected. Any_Type plays an important role in avoiding
-- cascaded errors, because it is compatible with all other types, and is
-- propagated to any expression that has a subexpression of Any_Type.
-- When resolving operators, Any_Type is the initial type of the node
-- before any of its candidate interpretations has been examined. If after
-- examining all of them the type is still Any_Type, the node has no
-- possible interpretation and an error can be emitted (and Any_Type will
-- be propagated upwards).
-- has been detected. Any_Type plays an important role in avoiding cascaded
-- errors, because it is compatible with all other types, and is propagated
-- to any expression that has a subexpression of Any_Type. When resolving
-- operators, Any_Type is the initial type of the node before any of its
-- candidate interpretations has been examined. If after examining all of
-- them the type is still Any_Type, the node has no possible interpretation
-- and an error can be emitted (and Any_Type will be propagated upwards).
--
-- There is one situation in which Any_Type is used to legitimately
-- represent a case where the type is not known pre-resolution, and
-- that is for the N_Raise_Expression node. In this case, the Etype
-- being set to Any_Type is normal and does not represent an error.
-- In particular, it is compatible with the type of any constituend of
-- the enclosing expression, if any. The type is eventually replaced
-- with the type of the context, which plays no role in the resolution
-- of the Raise_Expression.
-- represent a case where the type is not known pre-resolution, and that
-- is for the N_Raise_Expression node. In this case, the Etype being set to
-- Any_Type is normal and does not represent an error. In particular, it is
-- compatible with the type of any constituent of the enclosing expression,
-- if any. The type is eventually replaced with the type of the context,
-- which plays no role in the resolution of the Raise_Expression.
Any_Access : Entity_Id;
-- Used to resolve the overloaded literal NULL
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment