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.
-- --
-- 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- --
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;
-- 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.
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.
---------
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;
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 "=";
------------
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;
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);
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;
begin
if Count = 0 then
return;
- end if;
- if Count >= Length (Container) then
+ elsif Count >= Length (Container) then
Clear (Container);
return;
- end if;
- Delete (Container, Index_Type'First, Count);
+ else
+ Delete (Container, Index_Type'First, Count);
+ end if;
end Delete_First;
-----------------
end if;
end if;
- for J in Position.Index .. Container.Last loop
- if Container.Elements (To_Array_Index (J)) = Item then
- return (Container'Unrestricted_Access, J);
+ -- 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
+ 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;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Find;
----------------
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;
-----------
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;
-----------
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
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
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;
"attempt to tamper with cursors (vector is busy)";
end if;
- Sort (Container.Elements (1 .. Container.Length));
+ -- 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;
-- 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.
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.
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.
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.
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.
-- 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.
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.
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.
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.
-- 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.
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);
+ else
+ return No_Element;
end if;
-
- return No_Element;
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";
+ else
+ return Next (Position);
end if;
-
- return Next (Position);
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;
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;
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);
+ else
+ return No_Element;
end if;
-
- return No_Element;
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";
+ else
+ return Previous (Position);
end if;
-
- return Previous (Position);
end Previous;
-------------------
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
+ else
+ Query_Element (Position.Container.all, Position.Index, Process);
end if;
-
- Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
----------
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;
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;
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)";
+ else
+ Container.Elements (To_Array_Index (Index)) := New_Item;
end if;
-
- Container.Elements (To_Array_Index (Index)) := New_Item;
end Replace_Element;
procedure Replace_Element
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;
- Container.Elements (To_Array_Index (Position.Index)) := New_Item;
+ else
+ Container.Elements (To_Array_Index (Position.Index)) := New_Item;
+ end if;
end Replace_Element;
----------------------
then Container.Last
else Position.Index);
- for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements (To_Array_Index (Indx)) = Item then
- return (Container'Unrestricted_Access, Indx);
- end if;
- end loop;
+ -- 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
+ Result := Indx;
+ exit;
+ end if;
+ end loop;
+
+ B := B - 1;
+ L := L - 1;
- return No_Element;
+ 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;
------------------------
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;
---------------------
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;
-- 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);
-- --
-- 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- --
return (Controlled with Elements, Right.Last, 0, 0);
end;
-
end if;
if RN = 0 then
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);
---------
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;
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 "=";
------------
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;
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
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;
------------
begin
if Target'Address = Source'Address then
return;
+ else
+ Target.Clear;
+ Target.Append (Source);
end if;
-
- Target.Clear;
- Target.Append (Source);
end Assign;
--------------
begin
if Container.Elements = null then
return 0;
+ else
+ return Container.Elements.EA'Length;
end if;
-
- return Container.Elements.EA'Length;
end Capacity;
-----------
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
- end if;
- while Container.Last >= Index_Type'First loop
- declare
- X : Element_Access := Container.Elements.EA (Container.Last);
- begin
- Container.Elements.EA (Container.Last) := null;
- Container.Last := Container.Last - 1;
- Free (X);
- end;
- end loop;
+ else
+ while Container.Last >= Index_Type'First loop
+ declare
+ X : Element_Access := Container.Elements.EA (Container.Last);
+ begin
+ Container.Elements.EA (Container.Last) := null;
+ Container.Last := Container.Last - 1;
+ Free (X);
+ end;
+ end loop;
+ end if;
end Clear;
------------------------
if Index > Old_Last then
if Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)";
+ else
+ return;
end if;
-
- return;
end if;
-- Here and elsewhere we treat deleting 0 items from the container as a
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);
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;
-
- Delete (Container, Position.Index, Count);
- Position := No_Element;
+ else
+ Delete (Container, Position.Index, Count);
+ Position := No_Element;
+ end if;
end Delete;
------------------
begin
if Count = 0 then
return;
- end if;
- if Count >= Length (Container) then
+ elsif Count >= Length (Container) then
Clear (Container);
return;
- end if;
- Delete (Container, Index_Type'First, Count);
+ else
+ Delete (Container, Index_Type'First, Count);
+ end if;
end Delete_First;
-----------------
declare
EA : constant Element_Access := Container.Elements.EA (Index);
-
begin
if EA = null then
raise Constraint_Error with "element is empty";
+ else
+ return EA.all;
end if;
-
- return EA.all;
end;
end Element;
declare
EA : constant Element_Access :=
- Position.Container.Elements.EA (Position.Index);
-
+ Position.Container.Elements.EA (Position.Index);
begin
if EA = null then
raise Constraint_Error with "element is empty";
+ else
+ return EA.all;
end if;
-
- return EA.all;
end;
end Element;
end if;
end if;
- 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);
+ -- 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
+ 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;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Find;
----------------
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;
-----------
declare
EA : constant Element_Access :=
- Container.Elements.EA (Index_Type'First);
-
+ Container.Elements.EA (Index_Type'First);
begin
if EA = null then
raise Constraint_Error with "first element is empty";
+ else
+ return EA.all;
end if;
-
- return EA.all;
end;
end First_Element;
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;
-----------
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
I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source));
- 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))));
+ -- 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 (SA (Source.Last),
+ SA (Source.Last - 1))));
+
+ if I < Index_Type'First then
+ declare
+ Src : Elements_Array renames
+ SA (Index_Type'First .. Source.Last);
+ begin
+ TA (Index_Type'First .. J) := Src;
+ Src := (others => null);
+ end;
+
+ Source.Last := No_Index;
+ exit;
+ end if;
+
+ pragma Assert
+ (I <= Index_Type'First
+ or else not (Is_Less (TA (I), TA (I - 1))));
- if I < Index_Type'First then
declare
- Src : Elements_Array renames
- Source.Elements.EA (Index_Type'First .. Source.Last);
+ Src : Element_Access renames SA (Source.Last);
+ Tgt : Element_Access renames TA (I);
begin
- Target.Elements.EA (Index_Type'First .. J) := Src;
- Src := (others => null);
+ if Is_Less (Src, Tgt) then
+ Target.Elements.EA (J) := Tgt;
+ Tgt := null;
+ I := I - 1;
+
+ else
+ Target.Elements.EA (J) := Src;
+ Src := null;
+ Source.Last := Source.Last - 1;
+ end if;
end;
- Source.Last := No_Index;
- return;
- end if;
+ J := J - 1;
+ end loop;
- pragma Assert
- (I <= Index_Type'First
- or else not (Is_Less
- (Target.Elements.EA (I),
- Target.Elements.EA (I - 1))));
+ TB := TB - 1;
+ TL := TL - 1;
- declare
- Src : Element_Access renames Source.Elements.EA (Source.Last);
- Tgt : Element_Access renames Target.Elements.EA (I);
+ SB := SB - 1;
+ SL := SL - 1;
- begin
- if Is_Less (Src, Tgt) then
- Target.Elements.EA (J) := Tgt;
- Tgt := null;
- I := I - 1;
+ exception
+ when others =>
+ TB := TB - 1;
+ TL := TL - 1;
- else
- Target.Elements.EA (J) := Src;
- Src := null;
- Source.Last := Source.Last - 1;
- end if;
- end;
+ SB := SB - 1;
+ SL := SL - 1;
- J := J - 1;
- end loop;
+ raise;
+ end;
end Merge;
----------
"attempt to tamper with cursors (vector is busy)";
end if;
- Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
+ -- 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;
begin
if Position.Container = null then
return False;
+ else
+ return Position.Index <= Position.Container.Last;
end if;
-
- return Position.Index <= Position.Container.Last;
end Has_Element;
------------
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;
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);
-- 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);
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
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
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;
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;
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";
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);
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";
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";
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";
-- 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;
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;
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.
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;
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);
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;
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);
declare
EA : constant Element_Access :=
- Container.Elements.EA (Container.Last);
-
+ Container.Elements.EA (Container.Last);
begin
if EA = null then
raise Constraint_Error with "last element is empty";
+ else
+ return EA.all;
end if;
-
- return EA.all;
end;
end Last_Element;
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);
+ else
+ return No_Element;
end if;
-
- return No_Element;
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";
+ else
+ return Next (Position);
end if;
-
- return Next (Position);
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;
Count : Count_Type := 1)
is
begin
- Insert (Container,
- Index_Type'First,
- New_Item,
- Count);
+ Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
--------------
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;
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);
+ else
+ return No_Element;
end if;
-
- return No_Element;
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";
+ else
+ return Previous (Position);
end if;
-
- return Previous (Position);
end Previous;
-------------------
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
+ else
+ Query_Element (Position.Container.all, Position.Index, Process);
end if;
-
- Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
----------
is
Length : Count_Type'Base;
Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
-
- B : Boolean;
+ B : Boolean;
begin
Clear (Container);
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;
- 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);
+ -- 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
+ 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;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Reverse_Find;
------------------------
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;
---------------------
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;
+ else
+ return No_Index;
end if;
-
- return No_Index;
end To_Index;
---------------
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;
- Update_Element (Container, Position.Index, Process);
+ else
+ Update_Element (Container, Position.Index, Process);
+ end if;
end Update_Element;
-----------
end if;
declare
- RE : Elements_Array renames
- Right.Elements.EA (Index_Type'First .. Right.Last);
-
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(Right.Last, RE);
-
+ new Elements_Type'(Right.Last, RE);
begin
return (Controlled with Elements, Right.Last, 0, 0);
end;
if RN = 0 then
declare
- LE : Elements_Array renames
- Left.Elements.EA (Index_Type'First .. Left.Last);
-
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(Left.Last, LE);
-
+ new Elements_Type'(Left.Last, LE);
begin
return (Controlled with Elements, Left.Last, 0, 0);
end;
end if;
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);
-
+ 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);
-
+ new Elements_Type'(Last, LE & RE);
begin
return (Controlled with Elements, Last, 0, 0);
end;
end if;
declare
- Last : constant Index_Type := Left.Last + 1;
-
- LE : Elements_Array renames
- Left.Elements.EA (Index_Type'First .. Left.Last);
-
+ 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);
-
+ new Elements_Type'(Last => Last, EA => LE & Right);
begin
return (Controlled with Elements, Last, 0, 0);
end;
new Elements_Type'
(Last => Index_Type'First,
EA => (others => Left));
-
begin
return (Controlled with Elements, Index_Type'First, 0, 0);
end;
---------
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;
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 "=";
------------
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
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;
------------
begin
if Target'Address = Source'Address then
return;
+ else
+ Target.Clear;
+ Target.Append (Source);
end if;
-
- Target.Clear;
- Target.Append (Source);
end Assign;
--------------
if Index > Old_Last then
if Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)";
+ else
+ return;
end if;
-
- return;
end if;
-- Here and elsewhere we treat deleting 0 items from the container as a
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;
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);
declare
EA : Elements_Array renames Container.Elements.EA;
-
begin
EA (Index .. New_Last) := EA (J .. Old_Last);
Container.Last := New_Last;
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;
- Delete (Container, Position.Index, Count);
- Position := No_Element;
+ else
+ Delete (Container, Position.Index, Count);
+ Position := No_Element;
+ end if;
end Delete;
------------------
begin
if Count = 0 then
return;
- end if;
- if Count >= Length (Container) then
+ elsif Count >= Length (Container) then
Clear (Container);
return;
- end if;
- Delete (Container, Index_Type'First, Count);
+ else
+ Delete (Container, Index_Type'First, Count);
+ end if;
end Delete_First;
-----------------
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
+ else
+ return Container.Elements.EA (Index);
end if;
-
- return Container.Elements.EA (Index);
end Element;
function Element (Position : Cursor) return Element_Type is
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
- end if;
- Container.Elements := null;
- Container.Last := No_Index;
- Free (X);
+ else
+ Container.Elements := null;
+ Container.Last := No_Index;
+ Free (X);
+ end if;
end Finalize;
procedure Finalize (Object : in out Iterator) is
end if;
end if;
- for J in Position.Index .. Container.Last loop
- if Container.Elements.EA (J) = Item then
- return (Container'Unrestricted_Access, J);
+ -- 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
+ 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;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Find;
----------------
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;
-----------
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;
-----------
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
- or else not (SA (Source.Last) <
- SA (Source.Last - 1)));
+ or else not (SA (Source.Last) <
+ SA (Source.Last - 1)));
if I < Index_Type'First then
TA (Index_Type'First .. J) :=
SA (Index_Type'First .. Source.Last);
Source.Last := No_Index;
- return;
+ exit;
end if;
pragma Assert (I <= Index_Type'First
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;
"attempt to tamper with cursors (vector is busy)";
end if;
- Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
+ -- 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;
-- 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;
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;
if New_Capacity > Count_Type'Last / 2 then
New_Capacity := Count_Type'Last;
exit;
+ else
+ New_Capacity := 2 * New_Capacity;
end if;
-
- New_Capacity := 2 * New_Capacity;
end loop;
if New_Capacity > Max_Length then
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);
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;
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
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;
Index_Type'First .. L;
Src : Elements_Array renames
- Container.Elements.EA (Src_Index_Subtype);
+ Container.Elements.EA (Src_Index_Subtype);
K : Index_Type'Base;
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;
F .. Container.Last;
Src : Elements_Array renames
- Container.Elements.EA (Src_Index_Subtype);
+ Container.Elements.EA (Src_Index_Subtype);
K : Index_Type'Base;
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;
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";
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);
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";
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";
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);
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";
is
New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item);
-
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
-- 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;
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;
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);
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;
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);
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";
-- for a reverse iterator, Container.Last is the beginning.
return It : constant Iterator :=
- (Limited_Controlled with
- Container => V,
- Index => No_Index)
+ (Limited_Controlled with
+ Container => V,
+ Index => No_Index)
do
B := B + 1;
end return;
-- is a forward or reverse iteration.
return It : constant Iterator :=
- (Limited_Controlled with
- Container => V,
- Index => Start.Index)
+ (Limited_Controlled with
+ Container => V,
+ Index => Start.Index)
do
B := B + 1;
end return;
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";
+ else
+ return Next (Position);
end if;
-
- return Next (Position);
end Next;
procedure Next (Position : in out Cursor) 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;
--------------
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";
+ else
+ return Previous (Position);
end if;
-
- return Previous (Position);
end Previous;
procedure Previous (Position : in out Cursor) is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
+ else
+ Query_Element (Position.Container.all, Position.Index, Process);
end if;
-
- Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
----------
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
+
else
declare
C : Vector renames Container'Unrestricted_Access.all;
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)";
+ else
+ Container.Elements.EA (Index) := New_Item;
end if;
-
- Container.Elements.EA (Index) := New_Item;
end Replace_Element;
procedure Replace_Element
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
- raise Program_Error with
- "attempt to tamper with elements (vector is locked)";
- 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;
+ Container.Elements.EA (Position.Index) := New_Item;
+ end if;
end Replace_Element;
----------------------
then Container.Last
else Position.Index);
- for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements.EA (Indx) = Item then
- return (Container'Unrestricted_Access, Indx);
+ -- 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
+ 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;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Reverse_Find;
------------------------
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;
---------------------
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;
- Swap (Container, I.Index, J.Index);
+ else
+ Swap (Container, I.Index, J.Index);
+ end if;
end Swap;
---------------
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;
+ else
+ return No_Index;
end if;
-
- return No_Index;
end To_Index;
---------------
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
OSDN Git Service
