Skip to content

R
riscv-gcc-1
Commit 8bfbd380 by Arnaud Charlet
Options

[multiple changes] 

2013-04-11  Arnaud Charlet  <charlet@adacore.com>

	* gnat1drv.adb: Minor code clean up.

2013-04-11  Arnaud Charlet  <charlet@adacore.com>

	* debug.adb, sem_ch13.adb (Analyze_Enumeration_Representation_Clause):
	Ignore enumeration rep clauses by default in CodePeer mode, unless
	-gnatd.I is specified.

2013-04-11  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb (Safe_To_Capture_Value): If the node belongs to
	an expression that has been attached to the else_actions of an
	if-expression, the capture is not safe.

2013-04-11  Yannick Moy  <moy@adacore.com>

	* checks.adb (Apply_Type_Conversion_Checks): Put check mark on type
	conversion for arrays.

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

	* a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb: Minor reformatting.

2013-04-11  Johannes Kanig  <kanig@adacore.com>

	* adabkend.adb: Minor comment addition.

From-SVN: r197773
parent 256f3847
Showing with 587 additions and 539 deletions
gcc/ada/ChangeLog
2013-04-11 Arnaud Charlet <charlet@adacore.com>
* gnat1drv.adb: Minor code clean up.
2013-04-11 Arnaud Charlet <charlet@adacore.com>
* debug.adb, sem_ch13.adb (Analyze_Enumeration_Representation_Clause):
Ignore enumeration rep clauses by default in CodePeer mode, unless
-gnatd.I is specified.
2013-04-11 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (Safe_To_Capture_Value): If the node belongs to
an expression that has been attached to the else_actions of an
if-expression, the capture is not safe.
2013-04-11 Yannick Moy <moy@adacore.com>
* checks.adb (Apply_Type_Conversion_Checks): Put check mark on type
conversion for arrays.
2013-04-11 Robert Dewar <dewar@adacore.com>
* a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb: Minor reformatting.
2013-04-11 Johannes Kanig <kanig@adacore.com>
* adabkend.adb: Minor comment addition.
2013-04-11 Matthew Heaney <heaney@adacore.com> 2013-04-11 Matthew Heaney <heaney@adacore.com>
* a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb ("="): Increment * a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb ("="): Increment
......
gcc/ada/a-cbdlli.adb
...@@ -156,6 +156,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -156,6 +156,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
LR := LR - 1; LR := LR - 1;
return Result; return Result;
exception exception
when others => when others =>
BL := BL - 1; BL := BL - 1;
...@@ -359,20 +360,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -359,20 +360,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; 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 raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); else
pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
declare declare
N : Node_Type renames Container.Nodes (Position.Node); N : Node_Type renames Container.Nodes (Position.Node);
begin begin
return (Element => N.Element'Access); return (Element => N.Element'Access);
end; end;
end if;
end Constant_Reference; end Constant_Reference;
-------------- --------------
...@@ -397,10 +398,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -397,10 +398,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Capacity = 0 then if Capacity = 0 then
C := Source.Length; C := Source.Length;
elsif Capacity >= Source.Length then elsif Capacity >= Source.Length then
C := Capacity; C := Capacity;
else else
raise Capacity_Error with "Capacity value too small"; raise Capacity_Error with "Capacity value too small";
end if; end if;
...@@ -508,7 +507,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -508,7 +507,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if; end if;
for I in 1 .. Count loop for J in 1 .. Count loop
X := Container.First; X := Container.First;
pragma Assert (N (N (X).Next).Prev = Container.First); pragma Assert (N (N (X).Next).Prev = Container.First);
...@@ -547,7 +546,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -547,7 +546,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if; end if;
for I in 1 .. Count loop for J in 1 .. Count loop
X := Container.Last; X := Container.Last;
pragma Assert (N (N (X).Prev).Next = Container.Last); pragma Assert (N (N (X).Prev).Next = Container.Last);
...@@ -569,11 +568,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -569,11 +568,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
if Position.Node = 0 then if Position.Node = 0 then
raise Constraint_Error with raise Constraint_Error with
"Position cursor has no element"; "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Element"); else
pragma Assert (Vet (Position), "bad cursor in Element");
return Position.Container.Nodes (Position.Node).Element; return Position.Container.Nodes (Position.Node).Element;
end if;
end Element; end Element;
-------------- --------------
...@@ -585,7 +585,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -585,7 +585,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
if Object.Container /= null then if Object.Container /= null then
declare declare
B : Natural renames Object.Container.all.Busy; B : Natural renames Object.Container.all.Busy;
begin begin
B := B - 1; B := B - 1;
end; end;
...@@ -648,6 +647,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -648,6 +647,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
else else
return Cursor'(Container'Unrestricted_Access, Result); return Cursor'(Container'Unrestricted_Access, Result);
end if; end if;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -664,9 +664,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -664,9 +664,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Container.First = 0 then if Container.First = 0 then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.First);
end if; end if;
return Cursor'(Container'Unrestricted_Access, Container.First);
end First; end First;
function First (Object : Iterator) return Cursor is function First (Object : Iterator) return Cursor is
...@@ -699,9 +699,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -699,9 +699,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Container.First = 0 then if Container.First = 0 then
raise Constraint_Error with "list is empty"; raise Constraint_Error with "list is empty";
else
return Container.Nodes (Container.First).Element;
end if; end if;
return Container.Nodes (Container.First).Element;
end First_Element; end First_Element;
---------- ----------
...@@ -858,6 +858,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -858,6 +858,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
L := L - 1; L := L - 1;
return Result; return Result;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -962,6 +963,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -962,6 +963,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
SB := SB - 1; SB := SB - 1;
SL := SL - 1; SL := SL - 1;
exception exception
when others => when others =>
TB := TB - 1; TB := TB - 1;
...@@ -1076,6 +1078,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1076,6 +1078,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
B := B - 1; B := B - 1;
L := L - 1; L := L - 1;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -1287,7 +1290,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1287,7 +1290,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Process (Cursor'(Container'Unrestricted_Access, Node)); Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Container.Nodes (Node).Next; Node := Container.Nodes (Node).Next;
end loop; end loop;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -1315,9 +1317,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1315,9 +1317,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
-- for a reverse iterator, Container.Last is the beginning. -- for a reverse iterator, Container.Last is the beginning.
return It : constant Iterator := return It : constant Iterator :=
Iterator'(Limited_Controlled with Iterator'(Limited_Controlled with
Container => Container'Unrestricted_Access, Container => Container'Unrestricted_Access,
Node => 0) Node => 0)
do do
B := B + 1; B := B + 1;
end return; end return;
...@@ -1380,9 +1382,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1380,9 +1382,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Container.Last = 0 then if Container.Last = 0 then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.Last);
end if; end if;
return Cursor'(Container'Unrestricted_Access, Container.Last);
end Last; end Last;
function Last (Object : Iterator) return Cursor is function Last (Object : Iterator) return Cursor is
...@@ -1415,9 +1417,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1415,9 +1417,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Container.Last = 0 then if Container.Last = 0 then
raise Constraint_Error with "list is empty"; raise Constraint_Error with "list is empty";
else
return Container.Nodes (Container.Last).Element;
end if; end if;
return Container.Nodes (Container.Last).Element;
end Last_Element; end Last_Element;
------------ ------------
...@@ -1536,13 +1538,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1536,13 +1538,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
declare declare
Nodes : Node_Array renames Position.Container.Nodes; Nodes : Node_Array renames Position.Container.Nodes;
Node : constant Count_Type := Nodes (Position.Node).Next; Node : constant Count_Type := Nodes (Position.Node).Next;
begin begin
if Node = 0 then if Node = 0 then
return No_Element; return No_Element;
else
return Cursor'(Position.Container, Node);
end if; end if;
return Cursor'(Position.Container, Node);
end; end;
end Next; end Next;
...@@ -1553,14 +1554,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1553,14 +1554,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Next designates wrong list"; "Position cursor of Next designates wrong list";
else
return Next (Position);
end if; end if;
return Next (Position);
end Next; end Next;
------------- -------------
...@@ -1599,9 +1598,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1599,9 +1598,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Node = 0 then if Node = 0 then
return No_Element; return No_Element;
else
return Cursor'(Position.Container, Node);
end if; end if;
return Cursor'(Position.Container, Node);
end; end;
end Previous; end Previous;
...@@ -1612,14 +1611,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1612,14 +1611,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Previous designates wrong list"; "Position cursor of Previous designates wrong list";
else
return Previous (Position);
end if; end if;
return Previous (Position);
end Previous; end Previous;
------------------- -------------------
...@@ -1680,20 +1677,19 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1680,20 +1677,19 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
if N < 0 then if N < 0 then
raise Program_Error with "bad list length (corrupt stream)"; raise Program_Error with "bad list length (corrupt stream)";
end if;
if N = 0 then elsif N = 0 then
return; return;
end if;
if N > Item.Capacity then elsif N > Item.Capacity then
raise Constraint_Error with "length exceeds capacity"; raise Constraint_Error with "length exceeds capacity";
end if;
for Idx in 1 .. N loop else
Allocate (Item, Stream, New_Node => X); for Idx in 1 .. N loop
Insert_Internal (Item, Before => 0, New_Node => X); Allocate (Item, Stream, New_Node => X);
end loop; Insert_Internal (Item, Before => 0, New_Node => X);
end loop;
end if;
end Read; end Read;
procedure Read procedure Read
...@@ -1731,20 +1727,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1731,20 +1727,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; 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 raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in function Reference"); else
pragma Assert (Vet (Position), "bad cursor in function Reference");
declare declare
N : Node_Type renames Container.Nodes (Position.Node); N : Node_Type renames Container.Nodes (Position.Node);
begin begin
return (Element => N.Element'Access); return (Element => N.Element'Access);
end; end;
end if;
end Reference; end Reference;
--------------------- ---------------------
...@@ -1759,21 +1755,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1759,21 +1755,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then elsif Position.Container /= Container'Unchecked_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
if Container.Lock > 0 then elsif Container.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (list is locked)"; "attempt to tamper with elements (list is locked)";
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element"); else
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Container.Nodes (Position.Node).Element := New_Item; Container.Nodes (Position.Node).Element := New_Item;
end if;
end Replace_Element; end Replace_Element;
---------------------- ----------------------
...@@ -1919,6 +1914,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1919,6 +1914,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
else else
return Cursor'(Container'Unrestricted_Access, Result); return Cursor'(Container'Unrestricted_Access, Result);
end if; end if;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -1948,7 +1944,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1948,7 +1944,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Process (Cursor'(Container'Unrestricted_Access, Node)); Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Container.Nodes (Node).Prev; Node := Container.Nodes (Node).Prev;
end loop; end loop;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -1977,31 +1972,26 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -1977,31 +1972,26 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
pragma Assert (Vet (Before), "bad cursor in Splice"); pragma Assert (Vet (Before), "bad cursor in Splice");
end if; end if;
if Target'Address = Source'Address if Target'Address = Source'Address or else Source.Length = 0 then
or else Source.Length = 0
then
return; return;
end if;
if Target.Length > Count_Type'Last - Source.Length then elsif Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error with "new length exceeds maximum"; raise Constraint_Error with "new length exceeds maximum";
end if;
if Target.Length + Source.Length > Target.Capacity then elsif Target.Length + Source.Length > Target.Capacity then
raise Capacity_Error with "new length exceeds target capacity"; raise Capacity_Error with "new length exceeds target capacity";
end if;
if Target.Busy > 0 then elsif Target.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Target (list is busy)"; "attempt to tamper with cursors of Target (list is busy)";
end if;
if Source.Busy > 0 then elsif Source.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)"; "attempt to tamper with cursors of Source (list is busy)";
end if;
Splice_Internal (Target, Before.Node, Source); else
Splice_Internal (Target, Before.Node, Source);
end if;
end Splice; end Splice;
procedure Splice procedure Splice
...@@ -2583,7 +2573,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -2583,7 +2573,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
pragma Assert (N (Position.Node).Prev /= 0); pragma Assert (N (Position.Node).Prev /= 0);
-- ELiminate another possibility -- Eliminate another possibility
if Position.Node = L.Last then if Position.Node = L.Last then
return True; return True;
......
gcc/ada/a-cdlili.adb
...@@ -135,6 +135,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -135,6 +135,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
LR := LR - 1; LR := LR - 1;
return Result; return Result;
exception exception
when others => when others =>
BL := BL - 1; BL := BL - 1;
...@@ -404,6 +405,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -404,6 +405,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
Free (X); Free (X);
end loop; end loop;
-- The following comment is unacceptable, more detail needed ???
Position := No_Element; -- Post-York behavior Position := No_Element; -- Post-York behavior
end Delete; end Delete;
...@@ -432,7 +435,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -432,7 +435,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if; end if;
for I in 1 .. Count loop for J in 1 .. Count loop
X := Container.First; X := Container.First;
pragma Assert (X.Next.Prev = Container.First); pragma Assert (X.Next.Prev = Container.First);
...@@ -470,7 +473,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -470,7 +473,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if; end if;
for I in 1 .. Count loop for J in 1 .. Count loop
X := Container.Last; X := Container.Last;
pragma Assert (X.Prev.Next = Container.Last); pragma Assert (X.Prev.Next = Container.Last);
...@@ -492,11 +495,11 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -492,11 +495,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Position.Node = null then if Position.Node = null then
raise Constraint_Error with raise Constraint_Error with
"Position cursor has no element"; "Position cursor has no element";
end if; else
pragma Assert (Vet (Position), "bad cursor in Element");
pragma Assert (Vet (Position), "bad cursor in Element");
return Position.Node.Element; return Position.Node.Element;
end if;
end Element; end Element;
-------------- --------------
...@@ -549,9 +552,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -549,9 +552,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
else
pragma Assert (Vet (Position), "bad cursor in Find");
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Find");
end if; end if;
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
...@@ -572,9 +575,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -572,9 +575,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Node.Element = Item then if Node.Element = Item then
Result := Node; Result := Node;
exit; exit;
else
Node := Node.Next;
end if; end if;
Node := Node.Next;
end loop; end loop;
B := B - 1; B := B - 1;
...@@ -585,6 +588,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -585,6 +588,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
else else
return Cursor'(Container'Unrestricted_Access, Result); return Cursor'(Container'Unrestricted_Access, Result);
end if; end if;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -601,9 +605,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -601,9 +605,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Container.First = null then if Container.First = null then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.First);
end if; end if;
return Cursor'(Container'Unrestricted_Access, Container.First);
end First; end First;
function First (Object : Iterator) return Cursor is function First (Object : Iterator) return Cursor is
...@@ -636,9 +640,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -636,9 +640,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Container.First = null then if Container.First = null then
raise Constraint_Error with "list is empty"; raise Constraint_Error with "list is empty";
else
return Container.First.Element;
end if; end if;
return Container.First.Element;
end First_Element; end First_Element;
---------- ----------
...@@ -647,7 +651,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -647,7 +651,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Free (X : in out Node_Access) is procedure Free (X : in out Node_Access) is
procedure Deallocate is procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access); new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin begin
-- While a node is in use, as an active link in a list, its Previous and -- While a node is in use, as an active link in a list, its Previous and
-- Next components must be null, or designate a different node; this is -- Next components must be null, or designate a different node; this is
...@@ -708,6 +713,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -708,6 +713,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
L := L - 1; L := L - 1;
return Result; return Result;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -803,6 +809,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -803,6 +809,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
SB := SB - 1; SB := SB - 1;
SL := SL - 1; SL := SL - 1;
exception exception
when others => when others =>
TB := TB - 1; TB := TB - 1;
...@@ -830,9 +837,10 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -830,9 +837,10 @@ package body Ada.Containers.Doubly_Linked_Lists is
--------------- ---------------
procedure Partition (Pivot : Node_Access; Back : Node_Access) is procedure Partition (Pivot : Node_Access; Back : Node_Access) is
Node : Node_Access := Pivot.Next; Node : Node_Access;
begin begin
Node := Pivot.Next;
while Node /= Back loop while Node /= Back loop
if Node.Element < Pivot.Element then if Node.Element < Pivot.Element then
declare declare
...@@ -913,6 +921,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -913,6 +921,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
B := B - 1; B := B - 1;
L := L - 1; L := L - 1;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -954,34 +963,33 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -954,34 +963,33 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Before.Container /= Container'Unrestricted_Access then if Before.Container /= Container'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Before cursor designates wrong list"; "Before cursor designates wrong list";
else
pragma Assert (Vet (Before), "bad cursor in Insert");
end if; end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
end if; end if;
if Count = 0 then if Count = 0 then
Position := Before; Position := Before;
return; return;
end if;
if Container.Length > Count_Type'Last - Count then elsif Container.Length > Count_Type'Last - Count then
raise Constraint_Error with "new length exceeds maximum"; raise Constraint_Error with "new length exceeds maximum";
end if;
if Container.Busy > 0 then elsif Container.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if;
New_Node := new Node_Type'(New_Item, null, null);
Insert_Internal (Container, Before.Node, New_Node);
Position := Cursor'(Container'Unchecked_Access, New_Node); else
for J in Count_Type'(2) .. Count loop
New_Node := new Node_Type'(New_Item, null, null); New_Node := new Node_Type'(New_Item, null, null);
Insert_Internal (Container, Before.Node, New_Node); Insert_Internal (Container, Before.Node, New_Node);
end loop;
Position := Cursor'(Container'Unchecked_Access, New_Node);
for J in 2 .. Count loop
New_Node := new Node_Type'(New_Item, null, null);
Insert_Internal (Container, Before.Node, New_Node);
end loop;
end if;
end Insert; end Insert;
procedure Insert procedure Insert
...@@ -1009,9 +1017,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1009,9 +1017,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Before.Container /= Container'Unrestricted_Access then if Before.Container /= Container'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Before cursor designates wrong list"; "Before cursor designates wrong list";
else
pragma Assert (Vet (Before), "bad cursor in Insert");
end if; end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
end if; end if;
if Count = 0 then if Count = 0 then
...@@ -1021,22 +1029,22 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1021,22 +1029,22 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Container.Length > Count_Type'Last - Count then if Container.Length > Count_Type'Last - Count then
raise Constraint_Error with "new length exceeds maximum"; raise Constraint_Error with "new length exceeds maximum";
end if;
if Container.Busy > 0 then elsif Container.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if;
New_Node := new Node_Type;
Insert_Internal (Container, Before.Node, New_Node);
Position := Cursor'(Container'Unchecked_Access, New_Node); else
for J in Count_Type'(2) .. Count loop
New_Node := new Node_Type; New_Node := new Node_Type;
Insert_Internal (Container, Before.Node, New_Node); Insert_Internal (Container, Before.Node, New_Node);
end loop;
Position := Cursor'(Container'Unchecked_Access, New_Node);
for J in 2 .. Count loop
New_Node := new Node_Type;
Insert_Internal (Container, Before.Node, New_Node);
end loop;
end if;
end Insert; end Insert;
--------------------- ---------------------
...@@ -1141,9 +1149,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1141,9 +1149,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
-- for a reverse iterator, Container.Last is the beginning. -- for a reverse iterator, Container.Last is the beginning.
return It : constant Iterator := return It : constant Iterator :=
Iterator'(Limited_Controlled with Iterator'(Limited_Controlled with
Container => Container'Unrestricted_Access, Container => Container'Unrestricted_Access,
Node => null) Node => null)
do do
B := B + 1; B := B + 1;
end return; end return;
...@@ -1169,31 +1177,31 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1169,31 +1177,31 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Start = No_Element then if Start = No_Element then
raise Constraint_Error with raise Constraint_Error with
"Start position for iterator equals No_Element"; "Start position for iterator equals No_Element";
end if;
if Start.Container /= Container'Unrestricted_Access then elsif Start.Container /= Container'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Start cursor of Iterate designates wrong list"; "Start cursor of Iterate designates wrong list";
end if;
pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
-- The value of the Node component influences the behavior of the First else
-- and Last selector functions of the iterator object. When the Node pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
-- component is non-null (as is the case here), it means that this
-- is a partial iteration, over a subset of the complete sequence of -- The value of the Node component influences the behavior of the
-- items. The iterator object was constructed with a start expression, -- First and Last selector functions of the iterator object. When
-- indicating the position from which the iteration begins. Note that -- the Node component is non-null (as is the case here), it means
-- the start position has the same value irrespective of whether this -- that this is a partial iteration, over a subset of the complete
-- is a forward or reverse iteration. -- sequence of items. The iterator object was constructed with
-- a start expression, indicating the position from which the
return It : constant Iterator := -- iteration begins. Note that the start position has the same value
Iterator'(Limited_Controlled with -- irrespective of whether this is a forward or reverse iteration.
Container => Container'Unrestricted_Access,
Node => Start.Node) return It : constant Iterator :=
do Iterator'(Limited_Controlled with
B := B + 1; Container => Container'Unrestricted_Access,
end return; Node => Start.Node)
do
B := B + 1;
end return;
end if;
end Iterate; end Iterate;
---------- ----------
...@@ -1204,9 +1212,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1204,9 +1212,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Container.Last = null then if Container.Last = null then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.Last);
end if; end if;
return Cursor'(Container'Unrestricted_Access, Container.Last);
end Last; end Last;
function Last (Object : Iterator) return Cursor is function Last (Object : Iterator) return Cursor is
...@@ -1239,9 +1247,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1239,9 +1247,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Container.Last = null then if Container.Last = null then
raise Constraint_Error with "list is empty"; raise Constraint_Error with "list is empty";
else
return Container.Last.Element;
end if; end if;
return Container.Last.Element;
end Last_Element; end Last_Element;
------------ ------------
...@@ -1264,23 +1272,23 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1264,23 +1272,23 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
end if;
if Source.Busy > 0 then elsif Source.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)"; "attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target); else
Clear (Target);
Target.First := Source.First; Target.First := Source.First;
Source.First := null; Source.First := null;
Target.Last := Source.Last; Target.Last := Source.Last;
Source.Last := null; Source.Last := null;
Target.Length := Source.Length; Target.Length := Source.Length;
Source.Length := 0; Source.Length := 0;
end if;
end Move; end Move;
---------- ----------
...@@ -1296,20 +1304,20 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1296,20 +1304,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Position.Node = null then if Position.Node = null then
return No_Element; return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in Next");
declare else
Next_Node : constant Node_Access := Position.Node.Next; pragma Assert (Vet (Position), "bad cursor in Next");
begin
if Next_Node = null then
return No_Element;
end if;
return Cursor'(Position.Container, Next_Node); declare
end; Next_Node : constant Node_Access := Position.Node.Next;
begin
if Next_Node = null then
return No_Element;
else
return Cursor'(Position.Container, Next_Node);
end if;
end;
end if;
end Next; end Next;
function Next function Next
...@@ -1319,14 +1327,12 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1319,14 +1327,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Next designates wrong list"; "Position cursor of Next designates wrong list";
else
return Next (Position);
end if; end if;
return Next (Position);
end Next; end Next;
------------- -------------
...@@ -1355,20 +1361,20 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1355,20 +1361,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Position.Node = null then if Position.Node = null then
return No_Element; return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in Previous");
declare else
Prev_Node : constant Node_Access := Position.Node.Prev; pragma Assert (Vet (Position), "bad cursor in Previous");
begin
if Prev_Node = null then
return No_Element;
end if;
return Cursor'(Position.Container, Prev_Node); declare
end; Prev_Node : constant Node_Access := Position.Node.Prev;
begin
if Prev_Node = null then
return No_Element;
else
return Cursor'(Position.Container, Prev_Node);
end if;
end;
end if;
end Previous; end Previous;
function Previous function Previous
...@@ -1378,14 +1384,12 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1378,14 +1384,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Previous designates wrong list"; "Position cursor of Previous designates wrong list";
else
return Previous (Position);
end if; end if;
return Previous (Position);
end Previous; end Previous;
------------------- -------------------
...@@ -1514,28 +1518,28 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1514,28 +1518,28 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then elsif Position.Container /= Container'Unchecked_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in function Reference"); else
pragma Assert (Vet (Position), "bad cursor in function Reference");
declare declare
C : List renames Position.Container.all; C : List renames Position.Container.all;
B : Natural renames C.Busy; B : Natural renames C.Busy;
L : Natural renames C.Lock; L : Natural renames C.Lock;
begin begin
return R : constant Reference_Type := return R : constant Reference_Type :=
(Element => Position.Node.Element'Access, (Element => Position.Node.Element'Access,
Control => (Controlled with Position.Container)) Control => (Controlled with Position.Container))
do do
B := B + 1; B := B + 1;
L := L + 1; L := L + 1;
end return; end return;
end; end;
end if;
end Reference; end Reference;
--------------------- ---------------------
...@@ -1550,21 +1554,20 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1550,21 +1554,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then elsif Position.Container /= Container'Unchecked_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
if Container.Lock > 0 then elsif Container.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (list is locked)"; "attempt to tamper with elements (list is locked)";
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element"); else
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Position.Node.Element := New_Item; Position.Node.Element := New_Item;
end if;
end Replace_Element; end Replace_Element;
---------------------- ----------------------
...@@ -1673,9 +1676,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1673,9 +1676,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
else
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if; end if;
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
...@@ -1709,6 +1712,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1709,6 +1712,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
else else
return Cursor'(Container'Unrestricted_Access, Result); return Cursor'(Container'Unrestricted_Access, Result);
end if; end if;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -1738,7 +1742,6 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1738,7 +1742,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
Process (Cursor'(Container'Unrestricted_Access, Node)); Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Node.Prev; Node := Node.Prev;
end loop; end loop;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -1762,32 +1765,28 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1762,32 +1765,28 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Before.Container /= Target'Unrestricted_Access then if Before.Container /= Target'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Before cursor designates wrong container"; "Before cursor designates wrong container";
else
pragma Assert (Vet (Before), "bad cursor in Splice");
end if; end if;
pragma Assert (Vet (Before), "bad cursor in Splice");
end if; end if;
if Target'Address = Source'Address if Target'Address = Source'Address or else Source.Length = 0 then
or else Source.Length = 0
then
return; return;
end if;
if Target.Length > Count_Type'Last - Source.Length then elsif Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error with "new length exceeds maximum"; raise Constraint_Error with "new length exceeds maximum";
end if;
if Target.Busy > 0 then elsif Target.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Target (list is busy)"; "attempt to tamper with cursors of Target (list is busy)";
end if;
if Source.Busy > 0 then elsif Source.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)"; "attempt to tamper with cursors of Source (list is busy)";
end if;
Splice_Internal (Target, Before.Node, Source); else
Splice_Internal (Target, Before.Node, Source);
end if;
end Splice; end Splice;
procedure Splice procedure Splice
...@@ -1800,9 +1799,9 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1800,9 +1799,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Before.Container /= Container'Unchecked_Access then if Before.Container /= Container'Unchecked_Access then
raise Program_Error with raise Program_Error with
"Before cursor designates wrong container"; "Before cursor designates wrong container";
else
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if; end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if; end if;
if Position.Node = null then if Position.Node = null then
...@@ -1908,38 +1907,37 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1908,38 +1907,37 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Before.Container /= Target'Unrestricted_Access then if Before.Container /= Target'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Before cursor designates wrong container"; "Before cursor designates wrong container";
else
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if; end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if; end if;
if Position.Node = null then if Position.Node = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Source'Unrestricted_Access then elsif Position.Container /= Source'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice"); else
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then if Target.Length = Count_Type'Last then
raise Constraint_Error with "Target is full"; raise Constraint_Error with "Target is full";
end if;
if Target.Busy > 0 then elsif Target.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Target (list is busy)"; "attempt to tamper with cursors of Target (list is busy)";
end if;
if Source.Busy > 0 then elsif Source.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)"; "attempt to tamper with cursors of Source (list is busy)";
end if;
Splice_Internal (Target, Before.Node, Source, Position.Node); else
Position.Container := Target'Unchecked_Access; Splice_Internal (Target, Before.Node, Source, Position.Node);
Position.Container := Target'Unchecked_Access;
end if;
end if;
end Splice; end Splice;
--------------------- ---------------------
...@@ -2210,35 +2208,35 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -2210,35 +2208,35 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then elsif Position.Container /= Container'Unchecked_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element"); else
pragma Assert (Vet (Position), "bad cursor in Update_Element");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin declare
B := B + 1; B : Natural renames Container.Busy;
L := L + 1; L : Natural renames Container.Lock;
begin begin
Process (Position.Node.Element); B := B + 1;
exception L := L + 1;
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1; begin
B := B - 1; Process (Position.Node.Element);
end; exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end if;
end Update_Element; end Update_Element;
--------- ---------
...@@ -2305,8 +2303,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -2305,8 +2303,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
pragma Assert pragma Assert
(Position.Node.Prev /= null (Position.Node.Prev /= null or else Position.Node = L.First);
or else Position.Node = L.First);
if Position.Node.Next = null and then Position.Node /= L.Last then if Position.Node.Next = null and then Position.Node /= L.Last then
return False; return False;
......
gcc/ada/a-cidlli.adb
...@@ -138,6 +138,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -138,6 +138,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
LR := LR - 1; LR := LR - 1;
return Result; return Result;
exception exception
when others => when others =>
BL := BL - 1; BL := BL - 1;
...@@ -247,15 +248,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -247,15 +248,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
end if;
Target.Clear; else
Target.Clear;
Node := Source.First; Node := Source.First;
while Node /= null loop while Node /= null loop
Target.Append (Node.Element.all); Target.Append (Node.Element.all);
Node := Node.Next; Node := Node.Next;
end loop; end loop;
end if;
end Assign; end Assign;
----------- -----------
...@@ -316,32 +318,30 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -316,32 +318,30 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; 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 raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if; elsif Position.Node.Element = null then
if Position.Node.Element = null then
raise Program_Error with "Node has no element"; raise Program_Error with "Node has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); else
pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
declare declare
C : List renames Position.Container.all; C : List renames Position.Container.all;
B : Natural renames C.Busy; B : Natural renames C.Busy;
L : Natural renames C.Lock; L : Natural renames C.Lock;
begin begin
return R : constant Constant_Reference_Type := return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access, (Element => Position.Node.Element.all'Access,
Control => (Controlled with Position.Container)) Control => (Controlled with Position.Container))
do do
B := B + 1; B := B + 1;
L := L + 1; L := L + 1;
end return; end return;
end; end;
end if;
end Constant_Reference; end Constant_Reference;
-------------- --------------
...@@ -434,6 +434,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -434,6 +434,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Free (X); Free (X);
end loop; end loop;
-- Fix this junk comment ???
Position := No_Element; -- Post-York behavior Position := No_Element; -- Post-York behavior
end Delete; end Delete;
...@@ -451,28 +453,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -451,28 +453,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Count >= Container.Length then if Count >= Container.Length then
Clear (Container); Clear (Container);
return; return;
end if;
if Count = 0 then elsif Count = 0 then
return; return;
end if;
if Container.Busy > 0 then elsif Container.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if;
for I in 1 .. Count loop else
X := Container.First; for J in 1 .. Count loop
pragma Assert (X.Next.Prev = Container.First); X := Container.First;
pragma Assert (X.Next.Prev = Container.First);
Container.First := X.Next; Container.First := X.Next;
Container.First.Prev := null; Container.First.Prev := null;
Container.Length := Container.Length - 1; Container.Length := Container.Length - 1;
Free (X); Free (X);
end loop; end loop;
end if;
end Delete_First; end Delete_First;
----------------- -----------------
...@@ -489,28 +490,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -489,28 +490,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Count >= Container.Length then if Count >= Container.Length then
Clear (Container); Clear (Container);
return; return;
end if;
if Count = 0 then elsif Count = 0 then
return; return;
end if;
if Container.Busy > 0 then elsif Container.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if;
for I in 1 .. Count loop else
X := Container.Last; for J in 1 .. Count loop
pragma Assert (X.Prev.Next = Container.Last); X := Container.Last;
pragma Assert (X.Prev.Next = Container.Last);
Container.Last := X.Prev; Container.Last := X.Prev;
Container.Last.Next := null; Container.Last.Next := null;
Container.Length := Container.Length - 1; Container.Length := Container.Length - 1;
Free (X); Free (X);
end loop; end loop;
end if;
end Delete_Last; end Delete_Last;
------------- -------------
...@@ -522,16 +522,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -522,16 +522,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Position.Node = null then if Position.Node = null then
raise Constraint_Error with raise Constraint_Error with
"Position cursor has no element"; "Position cursor has no element";
end if;
if Position.Node.Element = null then elsif Position.Node.Element = null then
raise Program_Error with raise Program_Error with
"Position cursor has no element"; "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Element"); else
pragma Assert (Vet (Position), "bad cursor in Element");
return Position.Node.Element.all; return Position.Node.Element.all;
end if;
end Element; end Element;
-------------- --------------
...@@ -583,14 +583,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -583,14 +583,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
else else
if Node.Element = null then if Node.Element = null then
raise Program_Error; raise Program_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Find"); else
pragma Assert (Vet (Position), "bad cursor in Find");
end if;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
...@@ -624,6 +624,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -624,6 +624,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
else else
return Cursor'(Container'Unrestricted_Access, Result); return Cursor'(Container'Unrestricted_Access, Result);
end if; end if;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -640,9 +641,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -640,9 +641,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Container.First = null then if Container.First = null then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.First);
end if; end if;
return Cursor'(Container'Unrestricted_Access, Container.First);
end First; end First;
function First (Object : Iterator) return Cursor is function First (Object : Iterator) return Cursor is
...@@ -675,9 +676,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -675,9 +676,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Container.First = null then if Container.First = null then
raise Constraint_Error with "list is empty"; raise Constraint_Error with "list is empty";
else
return Container.First.Element.all;
end if; end if;
return Container.First.Element.all;
end First_Element; end First_Element;
---------- ----------
...@@ -747,7 +748,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -747,7 +748,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Node := Container.First; Node := Container.First;
Result := True; Result := True;
for I in 2 .. Container.Length loop for J in 2 .. Container.Length loop
if Node.Next.Element.all < Node.Element.all then if Node.Next.Element.all < Node.Element.all then
Result := False; Result := False;
exit; exit;
...@@ -760,6 +761,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -760,6 +761,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
L := L - 1; L := L - 1;
return Result; return Result;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -786,23 +788,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -786,23 +788,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Source.Is_Empty then if Source.Is_Empty then
return; return;
end if;
if Target'Address = Source'Address then elsif Target'Address = Source'Address then
raise Program_Error with raise Program_Error with
"Target and Source denote same non-empty container"; "Target and Source denote same non-empty container";
end if;
if Target.Length > Count_Type'Last - Source.Length then elsif Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error with "new length exceeds maximum"; raise Constraint_Error with "new length exceeds maximum";
end if;
if Target.Busy > 0 then elsif Target.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Target (list is busy)"; "attempt to tamper with cursors of Target (list is busy)";
end if;
if Source.Busy > 0 then elsif Source.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)"; "attempt to tamper with cursors of Source (list is busy)";
end if; end if;
...@@ -827,8 +825,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -827,8 +825,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
RI := Source.First; RI := Source.First;
while RI /= null loop while RI /= null loop
pragma Assert (RI.Next = null pragma Assert (RI.Next = null
or else not (RI.Next.Element.all < or else not (RI.Next.Element.all <
RI.Element.all)); RI.Element.all));
if LI = null then if LI = null then
Splice_Internal (Target, null, Source); Splice_Internal (Target, null, Source);
...@@ -836,8 +834,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -836,8 +834,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
pragma Assert (LI.Next = null pragma Assert (LI.Next = null
or else not (LI.Next.Element.all < or else not (LI.Next.Element.all <
LI.Element.all)); LI.Element.all));
if RI.Element.all < LI.Element.all then if RI.Element.all < LI.Element.all then
RJ := RI; RJ := RI;
...@@ -854,6 +852,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -854,6 +852,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
SB := SB - 1; SB := SB - 1;
SL := SL - 1; SL := SL - 1;
exception exception
when others => when others =>
TB := TB - 1; TB := TB - 1;
...@@ -872,22 +871,26 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -872,22 +871,26 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Sort (Container : in out List) is procedure Sort (Container : in out List) is
procedure Partition (Pivot : Node_Access; Back : Node_Access); procedure Partition (Pivot : Node_Access; Back : Node_Access);
-- Comment ???
procedure Sort (Front, Back : Node_Access); procedure Sort (Front, Back : Node_Access);
-- Comment??? Confusing name??? change name???
--------------- ---------------
-- Partition -- -- Partition --
--------------- ---------------
procedure Partition (Pivot : Node_Access; Back : Node_Access) is procedure Partition (Pivot : Node_Access; Back : Node_Access) is
Node : Node_Access := Pivot.Next; Node : Node_Access;
begin begin
Node := Pivot.Next;
while Node /= Back loop while Node /= Back loop
if Node.Element.all < Pivot.Element.all then if Node.Element.all < Pivot.Element.all then
declare declare
Prev : constant Node_Access := Node.Prev; Prev : constant Node_Access := Node.Prev;
Next : constant Node_Access := Node.Next; Next : constant Node_Access := Node.Next;
begin begin
Prev.Next := Next; Prev.Next := Next;
...@@ -1003,16 +1006,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1003,16 +1006,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Before.Container /= Container'Unrestricted_Access then if Before.Container /= Container'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (list is busy)"; "attempt to tamper with cursors (list is busy)";
end if;
if Before.Node = null elsif Before.Node = null or else Before.Node.Element = null then
or else Before.Node.Element = null
then
raise Program_Error with raise Program_Error with
"Before cursor has no element"; "Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad cursor in Insert"); else
pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
end if; end if;
if Count = 0 then if Count = 0 then
...@@ -1052,8 +1053,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1052,8 +1053,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Insert_Internal (Container, Before.Node, New_Node); Insert_Internal (Container, Before.Node, New_Node);
Position := Cursor'(Container'Unchecked_Access, New_Node); Position := Cursor'(Container'Unchecked_Access, New_Node);
for J in Count_Type'(2) .. Count loop for J in 2 .. Count loop
declare declare
Element : Element_Access := new Element_Type'(New_Item); Element : Element_Access := new Element_Type'(New_Item);
begin begin
...@@ -1183,9 +1183,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1183,9 +1183,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
-- for a reverse iterator, Container.Last is the beginning. -- for a reverse iterator, Container.Last is the beginning.
return It : constant Iterator := return It : constant Iterator :=
Iterator'(Limited_Controlled with Iterator'(Limited_Controlled with
Container => Container'Unrestricted_Access, Container => Container'Unrestricted_Access,
Node => null) Node => null)
do do
B := B + 1; B := B + 1;
end return; end return;
...@@ -1213,31 +1213,31 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1213,31 +1213,31 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Start = No_Element then if Start = No_Element then
raise Constraint_Error with raise Constraint_Error with
"Start position for iterator equals No_Element"; "Start position for iterator equals No_Element";
end if;
if Start.Container /= Container'Unrestricted_Access then elsif Start.Container /= Container'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Start cursor of Iterate designates wrong list"; "Start cursor of Iterate designates wrong list";
end if;
pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); else
pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
-- The value of the Node component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Node -- The value of the Node component influences the behavior of the
-- component is non-null (as is the case here), it means that this -- First and Last selector functions of the iterator object. When
-- is a partial iteration, over a subset of the complete sequence of -- the Node component is non-null (as is the case here), it means
-- items. The iterator object was constructed with a start expression, -- that this is a partial iteration, over a subset of the complete
-- indicating the position from which the iteration begins. Note that -- sequence of items. The iterator object was constructed with
-- the start position has the same value irrespective of whether this -- a start expression, indicating the position from which the
-- is a forward or reverse iteration. -- iteration begins. Note that the start position has the same value
-- irrespective of whether this is a forward or reverse iteration.
return It : constant Iterator :=
Iterator'(Limited_Controlled with return It : constant Iterator :=
Container => Container'Unrestricted_Access, Iterator'(Limited_Controlled with
Node => Start.Node) Container => Container'Unrestricted_Access,
do Node => Start.Node)
B := B + 1; do
end return; B := B + 1;
end return;
end if;
end Iterate; end Iterate;
---------- ----------
...@@ -1248,9 +1248,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1248,9 +1248,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Container.Last = null then if Container.Last = null then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.Last);
end if; end if;
return Cursor'(Container'Unrestricted_Access, Container.Last);
end Last; end Last;
function Last (Object : Iterator) return Cursor is function Last (Object : Iterator) return Cursor is
...@@ -1283,9 +1283,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1283,9 +1283,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Container.Last = null then if Container.Last = null then
raise Constraint_Error with "list is empty"; raise Constraint_Error with "list is empty";
else
return Container.Last.Element.all;
end if; end if;
return Container.Last.Element.all;
end Last_Element; end Last_Element;
------------ ------------
...@@ -1305,23 +1305,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1305,23 +1305,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
end if;
if Source.Busy > 0 then elsif Source.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)"; "attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target); else
Clear (Target);
Target.First := Source.First; Target.First := Source.First;
Source.First := null; Source.First := null;
Target.Last := Source.Last; Target.Last := Source.Last;
Source.Last := null; Source.Last := null;
Target.Length := Source.Length; Target.Length := Source.Length;
Source.Length := 0; Source.Length := 0;
end if;
end Move; end Move;
---------- ----------
...@@ -1337,33 +1337,32 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1337,33 +1337,32 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Position.Node = null then if Position.Node = null then
return No_Element; return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in Next"); else
pragma Assert (Vet (Position), "bad cursor in Next");
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
if Next_Node = null then
return No_Element;
end if;
return Cursor'(Position.Container, Next_Node); declare
end; Next_Node : constant Node_Access := Position.Node.Next;
begin
if Next_Node = null then
return No_Element;
else
return Cursor'(Position.Container, Next_Node);
end if;
end;
end if;
end Next; end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is function Next (Object : Iterator; Position : Cursor) return Cursor is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Next designates wrong list"; "Position cursor of Next designates wrong list";
else
return Next (Position);
end if; end if;
return Next (Position);
end Next; end Next;
------------- -------------
...@@ -1392,33 +1391,32 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1392,33 +1391,32 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Position.Node = null then if Position.Node = null then
return No_Element; return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in Previous"); else
pragma Assert (Vet (Position), "bad cursor in Previous");
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
if Prev_Node = null then
return No_Element;
end if;
return Cursor'(Position.Container, Prev_Node); declare
end; Prev_Node : constant Node_Access := Position.Node.Prev;
begin
if Prev_Node = null then
return No_Element;
else
return Cursor'(Position.Container, Prev_Node);
end if;
end;
end if;
end Previous; end Previous;
function Previous (Object : Iterator; Position : Cursor) return Cursor is function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Previous designates wrong list"; "Position cursor of Previous designates wrong list";
else
return Previous (Position);
end if; end if;
return Previous (Position);
end Previous; end Previous;
------------------- -------------------
...@@ -1433,36 +1431,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1433,36 +1431,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Position.Node = null then if Position.Node = null then
raise Constraint_Error with raise Constraint_Error with
"Position cursor has no element"; "Position cursor has no element";
end if;
if Position.Node.Element = null then elsif Position.Node.Element = null then
raise Program_Error with raise Program_Error with
"Position cursor has no element"; "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
declare else
C : List renames Position.Container.all'Unrestricted_Access.all; pragma Assert (Vet (Position), "bad cursor in Query_Element");
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin declare
B := B + 1; C : List renames Position.Container.all'Unrestricted_Access.all;
L := L + 1; B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin begin
Process (Position.Node.Element.all); B := B + 1;
exception L := L + 1;
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1; begin
B := B - 1; Process (Position.Node.Element.all);
end; exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end if;
end Query_Element; end Query_Element;
---------- ----------
...@@ -1487,7 +1485,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1487,7 +1485,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
declare declare
Element : Element_Access := Element : Element_Access :=
new Element_Type'(Element_Type'Input (Stream)); new Element_Type'(Element_Type'Input (Stream));
begin begin
Dst := new Node_Type'(Element, null, null); Dst := new Node_Type'(Element, null, null);
exception exception
...@@ -1503,7 +1501,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1503,7 +1501,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
while Item.Length < N loop while Item.Length < N loop
declare declare
Element : Element_Access := Element : Element_Access :=
new Element_Type'(Element_Type'Input (Stream)); new Element_Type'(Element_Type'Input (Stream));
begin begin
Dst := new Node_Type'(Element, Next => null, Prev => Item.Last); Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
exception exception
...@@ -1553,32 +1551,31 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1553,32 +1551,31 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; 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 raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
if Position.Node.Element = null then elsif Position.Node.Element = null then
raise Program_Error with "Node has no element"; raise Program_Error with "Node has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in function Reference"); else
pragma Assert (Vet (Position), "bad cursor in function Reference");
declare declare
C : List renames Position.Container.all; C : List renames Position.Container.all;
B : Natural renames C.Busy; B : Natural renames C.Busy;
L : Natural renames C.Lock; L : Natural renames C.Lock;
begin begin
return R : constant Reference_Type := return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access, (Element => Position.Node.Element.all'Access,
Control => (Controlled with Position.Container)) Control => (Controlled with Position.Container))
do do
B := B + 1; B := B + 1;
L := L + 1; L := L + 1;
end return; end return;
end; end;
end if;
end Reference; end Reference;
--------------------- ---------------------
...@@ -1593,38 +1590,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1593,38 +1590,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then elsif Position.Container /= Container'Unchecked_Access then
raise Program_Error with raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
if Container.Lock > 0 then elsif Container.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (list is locked)"; "attempt to tamper with elements (list is locked)";
end if;
if Position.Node.Element = null then elsif Position.Node.Element = null then
raise Program_Error with raise Program_Error with
"Position cursor has no element"; "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element"); else
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
declare declare
-- The element allocator may need an accessibility check in the case -- The element allocator may need an accessibility check in the
-- the actual type is class-wide or has access discriminants (see -- case the actual type is class-wide or has access discriminants
-- RM 4.8(10.1) and AI12-0035). -- (see RM 4.8(10.1) and AI12-0035).
pragma Unsuppress (Accessibility_Check); pragma Unsuppress (Accessibility_Check);
X : Element_Access := Position.Node.Element; X : Element_Access := Position.Node.Element;
begin begin
Position.Node.Element := new Element_Type'(New_Item); Position.Node.Element := new Element_Type'(New_Item);
Free (X); Free (X);
end; end;
end if;
end Replace_Element; end Replace_Element;
---------------------- ----------------------
...@@ -1732,14 +1727,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1732,14 +1727,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
else else
if Node.Element = null then if Node.Element = null then
raise Program_Error with "Position cursor has no element"; raise Program_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 raise Program_Error with
"Position cursor designates wrong container"; "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); else
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
...@@ -1773,6 +1768,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1773,6 +1768,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
else else
return Cursor'(Container'Unrestricted_Access, Result); return Cursor'(Container'Unrestricted_Access, Result);
end if; end if;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -1825,39 +1821,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1825,39 +1821,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Before.Container /= Target'Unrestricted_Access then if Before.Container /= Target'Unrestricted_Access then
raise Program_Error with raise Program_Error with
"Before cursor designates wrong container"; "Before cursor designates wrong container";
end if;
if Before.Node = null elsif Before.Node = null or else Before.Node.Element = null then
or else Before.Node.Element = null
then
raise Program_Error with raise Program_Error with
"Before cursor has no element"; "Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad cursor in Splice"); else
pragma Assert (Vet (Before), "bad cursor in Splice");
end if;
end if; end if;
if Target'Address = Source'Address if Target'Address = Source'Address or else Source.Length = 0 then
or else Source.Length = 0
then
return; return;
end if;
if Target.Length > Count_Type'Last - Source.Length then elsif Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error with "new length exceeds maximum"; raise Constraint_Error with "new length exceeds maximum";
end if;
if Target.Busy > 0 then elsif Target.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Target (list is busy)"; "attempt to tamper with cursors of Target (list is busy)";
end if;
if Source.Busy > 0 then elsif Source.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)"; "attempt to tamper with cursors of Source (list is busy)";
end if;
Splice_Internal (Target, Before.Node, Source); else
Splice_Internal (Target, Before.Node, Source);
end if;
end Splice; end Splice;
procedure Splice procedure Splice
...@@ -1870,16 +1860,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1870,16 +1860,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Before.Container /= Container'Unchecked_Access then if Before.Container /= Container'Unchecked_Access then
raise Program_Error with raise Program_Error with
"Before cursor designates wrong container"; "Before cursor designates wrong container";
end if;
if Before.Node = null elsif Before.Node = null or else Before.Node.Element = null then
or else Before.Node.Element = null
then
raise Program_Error with raise Program_Error with
"Before cursor has no element"; "Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice"); else
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
end if; end if;
if Position.Node = null then if Position.Node = null then
......
gcc/ada/adabkend.adb
...@@ -234,8 +234,15 @@ package body Adabkend is ...@@ -234,8 +234,15 @@ package body Adabkend is
then then
if Is_Switch (Argv) then if Is_Switch (Argv) then
Fail ("Object file name missing after -gnatO"); Fail ("Object file name missing after -gnatO");
-- In Alfa_Mode, such an object file is never written, and the
-- call to Set_Output_Object_File_Name may fail (e.g. when the
-- object file name does not have the expected suffix). So we
-- skip that call when Alfa_Mode is set.
elsif Alfa_Mode then elsif Alfa_Mode then
Output_File_Name_Seen := True; Output_File_Name_Seen := True;
else else
Set_Output_Object_File_Name (Argv); Set_Output_Object_File_Name (Argv);
Output_File_Name_Seen := True; Output_File_Name_Seen := True;
......
gcc/ada/checks.adb
...@@ -3244,13 +3244,18 @@ package body Checks is ...@@ -3244,13 +3244,18 @@ package body Checks is
Reason => CE_Discriminant_Check_Failed)); Reason => CE_Discriminant_Check_Failed));
end; end;
-- For arrays, conversions are applied during expansion, to take into -- For arrays, checks are set now, but conversions are applied during
-- accounts changes of representation. The checks become range checks on -- expansion, to take into accounts changes of representation. The
-- the base type or length checks on the subtype, depending on whether -- checks become range checks on the base type or length checks on the
-- the target type is unconstrained or constrained. -- subtype, depending on whether the target type is unconstrained or
-- constrained.
else
null; elsif Is_Array_Type (Target_Type) then
if Is_Constrained (Target_Type) then
Set_Do_Length_Check (N);
else
Set_Do_Range_Check (Expr);
end if;
end if; end if;
end Apply_Type_Conversion_Checks; end Apply_Type_Conversion_Checks;
......
gcc/ada/debug.adb
...@@ -126,7 +126,7 @@ package body Debug is ...@@ -126,7 +126,7 @@ package body Debug is
-- d.F Alfa mode -- d.F Alfa mode
-- d.G Frame condition mode for gnat2why -- d.G Frame condition mode for gnat2why
-- d.H Standard package only mode for gnat2why -- d.H Standard package only mode for gnat2why
-- d.I -- d.I Do not ignore enum representation clauses in CodePeer mode
-- d.J Disable parallel SCIL generation mode -- d.J Disable parallel SCIL generation mode
-- d.K Alfa detection only mode for gnat2why -- d.K Alfa detection only mode for gnat2why
-- d.L Depend on back end for limited types in if and case expressions -- d.L Depend on back end for limited types in if and case expressions
...@@ -614,6 +614,12 @@ package body Debug is ...@@ -614,6 +614,12 @@ package body Debug is
-- will only generate Why code for package Standard. Any given input -- will only generate Why code for package Standard. Any given input
-- file will be ignored. -- file will be ignored.
-- d.I Do not ignore enum representation clauses in CodePeer mode.
-- The default of ignoring representation clauses for enumeration
-- types in CodePeer is good for the majority of Ada code, but in some
-- cases being able to change this default might be useful to remove
-- some false positives.
-- d.J Disable parallel SCIL generation. Normally SCIL file generation is -- d.J Disable parallel SCIL generation. Normally SCIL file generation is
-- done in parallel to speed processing. This switch disables this -- done in parallel to speed processing. This switch disables this
-- behavior. -- behavior.
......
gcc/ada/gnat1drv.adb
...@@ -293,11 +293,15 @@ procedure Gnat1drv is ...@@ -293,11 +293,15 @@ procedure Gnat1drv is
Formal_Extensions := True; Formal_Extensions := True;
end if; end if;
-- Alfa_Mode is activated by default in the gnat2why executable, but -- Enable Alfa_Mode when using -gnatd.F switch
-- can also be activated using the -gnatd.F switch.
if Debug_Flag_Dot_FF or else Alfa_Mode then if Debug_Flag_Dot_FF then
Alfa_Mode := True; Alfa_Mode := True;
end if;
-- Alfa_Mode is also activated by default in the gnat2why executable
if Alfa_Mode then
-- Set strict standard interpretation of compiler permissions -- Set strict standard interpretation of compiler permissions
......
gcc/ada/sem_ch13.adb
...@@ -26,6 +26,7 @@ ...@@ -26,6 +26,7 @@
with Aspects; use Aspects; with Aspects; use Aspects;
with Atree; use Atree; with Atree; use Atree;
with Checks; use Checks; with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
...@@ -4253,6 +4254,14 @@ package body Sem_Ch13 is ...@@ -4253,6 +4254,14 @@ package body Sem_Ch13 is
return; return;
end if; end if;
-- Ignore enumeration rep clauses by default in CodePeer mode,
-- unless -gnatd.I is specified, as a work around for potential false
-- positive messages.
if CodePeer_Mode and not Debug_Flag_Dot_II then
return;
end if;
-- First some basic error checks -- First some basic error checks
Find_Type (Ident); Find_Type (Ident);
......
gcc/ada/sem_util.adb
...@@ -12984,6 +12984,19 @@ package body Sem_Util is ...@@ -12984,6 +12984,19 @@ package body Sem_Util is
else else
Desc := P; Desc := P;
P := Parent (P); P := Parent (P);
-- A special Ada 2012 case: the original node may be part
-- of the else_actions of a conditional expression, in which
-- case it might not have been expanded yet, and appears in
-- a non-syntactic list of actions. In that case it is clearly
-- not safe to save a value.
if No (P)
and then Is_List_Member (Desc)
and then No (Parent (List_Containing (Desc)))
then
return False;
end if;
end if; end if;
end loop; end loop;
end; end;
......
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