OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

par_sco.adb, [...]: Minor reformatting.

Browse Source 
2011-08-05  Robert Dewar  <dewar@adacore.com>

	* par_sco.adb, sem_ch3.adb, scos.ads, a-iteint.ads, sem_ch12.adb,
	a-cimutr.adb, a-cimutr.ads, sem_util.ads, sem_res.adb, a-fihema.adb,
	sem_ch4.adb, lib-xref-alfa.adb, exp_disp.adb, a-comutr.adb,
	a-comutr.ads, lib-xref.adb: Minor reformatting.

2011-08-05  Robert Dewar  <dewar@adacore.com>

	* sem_ch11.adb (Analyze_Raise_Statement): Kill assignment to formal
	warning if there is an exception handler present.

From-SVN: r177451
This commit is contained in:
Robert Dewar 2011-08-05 15:10:50 +00:00 committed by Arnaud Charlet
parent 7c62a85a8d
commit dedac3eb73
18 changed files with 468 additions and 451 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/ada/ChangeLog
View File

@ -1,3 +1,15 @@
2011-08-05 Robert Dewar <dewar@adacore.com>
* par_sco.adb, sem_ch3.adb, scos.ads, a-iteint.ads, sem_ch12.adb,
a-cimutr.adb, a-cimutr.ads, sem_util.ads, sem_res.adb, a-fihema.adb,
sem_ch4.adb, lib-xref-alfa.adb, exp_disp.adb, a-comutr.adb,
a-comutr.ads, lib-xref.adb: Minor reformatting.
2011-08-05 Robert Dewar <dewar@adacore.com>
* sem_ch11.adb (Analyze_Raise_Statement): Kill assignment to formal
warning if there is an exception handler present.
2011-08-05 Pascal Obry <obry@adacore.com>
* a-iteint.ads: Fix copyright year.

298
gcc/ada/a-cimutr.adb
View File

@ -134,25 +134,24 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Target_Count : Count_Type;
begin
-- We first restore the target container to its
-- default-initialized state, before we attempt any
-- allocation, to ensure that invariants are preserved
-- in the event that the allocation fails.
-- We first restore the target container to its default-initialized
-- state, before we attempt any allocation, to ensure that invariants
-- are preserved in the event that the allocation fails.
Container.Root.Children := Children_Type'(others => null);
Container.Busy := 0;
Container.Lock := 0;
Container.Count := 0;
-- Copy_Children returns a count of the number of nodes
-- that it allocates, but it works by incrementing the
-- value that is passed in. We must therefore initialize
-- the count value before calling Copy_Children.
-- Copy_Children returns a count of the number of nodes that it
-- allocates, but it works by incrementing the value that is passed in.
-- We must therefore initialize the count value before calling
-- Copy_Children.
Target_Count := 0;
-- Now we attempt the allocation of subtrees. The invariants
-- are satisfied even if the allocation fails.
-- Now we attempt the allocation of subtrees. The invariants are
-- satisfied even if the allocation fails.
Copy_Children (Source, Root_Node (Container), Target_Count);
pragma Assert (Target_Count = Source_Count);
@ -181,11 +180,10 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "Position cursor not in container";
end if;
-- AI-0136 says to raise PE if Position equals the root node.
-- This does not seem correct, as this value is just the limiting
-- condition of the search. For now we omit this check,
-- pending a ruling from the ARG. ???
--
-- AI-0136 says to raise PE if Position equals the root node. This does
-- not seem correct, as this value is just the limiting condition of the
-- search. For now we omit this check pending a ruling from the ARG.???
-- if Is_Root (Position) then
-- raise Program_Error with "Position cursor designates root";
-- end if;
@ -241,6 +239,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Last := First;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Element := new Element_Type'(New_Item);
@ -258,10 +257,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Parent => Parent.Node,
Before => null); -- null means "insert at end of list"
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Append_Child;
@ -281,16 +279,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Target.Clear; -- checks busy bit
-- Copy_Children returns the number of nodes that it allocates,
-- but it does this by incrementing the count value passed in,
-- so we must initialize the count before calling Copy_Children.
-- Copy_Children returns the number of nodes that it allocates, but it
-- does this by incrementing the count value passed in, so we must
-- initialize the count before calling Copy_Children.
Target_Count := 0;
-- Note that Copy_Children inserts the newly-allocated children
-- into their parent list only after the allocation of all the
-- children has succeeded. This preserves invariants even if
-- the allocation fails.
-- Note that Copy_Children inserts the newly-allocated children into
-- their parent list only after the allocation of all the children has
-- succeeded. This preserves invariants even if the allocation fails.
Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
pragma Assert (Target_Count = Source_Count);
@ -303,7 +300,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
-----------
procedure Clear (Container : in out Tree) is
Container_Count, Children_Count : Count_Type;
Container_Count : Count_Type;
Children_Count : Count_Type;
begin
if Container.Busy > 0 then
@ -311,28 +309,24 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
with "attempt to tamper with cursors (tree is busy)";
end if;
-- We first set the container count to 0, in order to
-- preserve invariants in case the deallocation fails.
-- (This works because Deallocate_Children immediately
-- removes the children from their parent, and then
-- does the actual deallocation.)
-- We first set the container count to 0, in order to preserve
-- invariants in case the deallocation fails. (This works because
-- Deallocate_Children immediately removes the children from their
-- parent, and then does the actual deallocation.)
Container_Count := Container.Count;
Container.Count := 0;
-- Deallocate_Children returns the number of nodes that
-- it deallocates, but it does this by incrementing the
-- count value that is passed in, so we must first initialize
-- the count return value before calling it.
-- Deallocate_Children returns the number of nodes that it deallocates,
-- but it does this by incrementing the count value that is passed in,
-- so we must first initialize the count return value before calling it.
Children_Count := 0;
-- See comment above. Deallocate_Children immediately
-- removes the children list from their parent node (here,
-- the root of the tree), and only after that does it
-- attempt the actual deallocation. So even if the
-- deallocation fails, the representation invariants
-- for the tree are preserved.
-- See comment above. Deallocate_Children immediately removes the
-- children list from their parent node (here, the root of the tree),
-- and only after that does it attempt the actual deallocation. So even
-- if the deallocation fails, the representation invariants
Deallocate_Children (Root_Node (Container), Children_Count);
pragma Assert (Children_Count = Container_Count);
@ -383,9 +377,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
C : Tree_Node_Access;
begin
-- We special-case the first allocation, in order
-- to establish the representation invariants
-- for type Children_Type.
-- We special-case the first allocation, in order to establish the
-- representation invariants for type Children_Type.
C := Source.First;
@ -401,9 +394,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
CC.Last := CC.First;
-- The representation invariants for the Children_Type
-- list have been established, so we can now copy
-- the remaining children of Source.
-- The representation invariants for the Children_Type list have been
-- established, so we can now copy the remaining children of Source.
C := C.Next;
while C /= null loop
@ -419,9 +411,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
C := C.Next;
end loop;
-- We add the newly-allocated children to their parent list
-- only after the allocation has succeeded, in order to
-- preserve invariants of the parent.
-- We add the newly-allocated children to their parent list only after
-- the allocation has succeeded, in order to preserve invariants of the
-- parent.
Parent.Children := CC;
end Copy_Children;
@ -450,6 +442,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Result := Result + 1;
Node := Node.Next;
end loop;
return Result;
end Child_Count;
@ -484,6 +477,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Program_Error with "Parent is not ancestor of Child";
end if;
end loop;
return Result;
end Child_Depth;
@ -527,10 +521,10 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
raise Constraint_Error with "Source cursor designates root";
end if;
-- Copy_Subtree returns a count of the number of nodes
-- that it allocates, but it works by incrementing the
-- value that is passed in. We must therefore initialize
-- the count value before calling Copy_Subtree.
-- Copy_Subtree returns a count of the number of nodes that it
-- allocates, but it works by incrementing the value that is passed in.
-- We must therefore initialize the count value before calling
-- Copy_Subtree.
Target_Count := 0;
@ -549,10 +543,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Parent => Parent.Node,
Before => Before.Node);
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Target.Count := Target.Count + Target_Count;
end Copy_Subtree;
@ -590,9 +583,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
C : Tree_Node_Access;
begin
-- We immediately remove the children from their
-- parent, in order to preserve invariants in case
-- the deallocation fails.
-- We immediately remove the children from their parent, in order to
-- preserve invariants in case the deallocation fails.
Subtree.Children := Children_Type'(others => null);
@ -707,16 +699,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
X := Position.Node;
Position := No_Element;
-- Restore represention invariants before attempting the
-- actual deallocation.
-- Restore represention invariants before attempting the actual
-- deallocation.
Remove_Subtree (X);
Container.Count := Container.Count - 1;
-- It is now safe to attempt the deallocation. This leaf
-- node has been disassociated from the tree, so even if
-- the deallocation fails, representation invariants
-- will remain satisfied.
-- It is now safe to attempt the deallocation. This leaf node has been
-- disassociated from the tree, so even if the deallocation fails,
-- representation invariants will remain satisfied.
Deallocate_Node (X);
end Delete_Leaf;
@ -753,38 +744,35 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
X := Position.Node;
Position := No_Element;
-- Here is one case where a deallocation failure can
-- result in the violation of a representation invariant.
-- We disassociate the subtree from the tree now, but we
-- only decrement the total node count after we attempt
-- the deallocation. However, if the deallocation fails,
-- the total node count will not get decremented.
--
-- One way around this dilemma is to count the nodes
-- in the subtree before attempt to delete the subtree,
-- but that is an O(n) operation, so it does not seem
-- worth it.
--
-- Perhaps this is much ado about nothing, since the
-- only way deallocation can fail is if Controlled
-- Finalization fails: this propagates Program_Error
-- so all bets are off anyway. ???
-- Here is one case where a deallocation failure can result in the
-- violation of a representation invariant. We disassociate the subtree
-- from the tree now, but we only decrement the total node count after
-- we attempt the deallocation. However, if the deallocation fails, the
-- total node count will not get decremented.
-- One way around this dilemma is to count the nodes in the subtree
-- before attempt to delete the subtree, but that is an O(n) operation,
-- so it does not seem worth it.
-- Perhaps this is much ado about nothing, since the only way
-- deallocation can fail is if Controlled Finalization fails: this
-- propagates Program_Error so all bets are off anyway. ???
Remove_Subtree (X);
-- Deallocate_Subtree returns a count of the number of nodes
-- that it deallocates, but it works by incrementing the
-- value that is passed in. We must therefore initialize
-- the count value before calling Deallocate_Subtree.
-- Deallocate_Subtree returns a count of the number of nodes that it
-- deallocates, but it works by incrementing the value that is passed
-- in. We must therefore initialize the count value before calling
-- Deallocate_Subtree.
Count := 0;
Deallocate_Subtree (X, Count);
pragma Assert (Count <= Container.Count);
-- See comments above. We would prefer to do this
-- sooner, but there's no way to satisfy that goal
-- without an potentially severe execution penalty.
-- See comments above. We would prefer to do this sooner, but there's no
-- way to satisfy that goal without an potentially severe execution
-- penalty.
Container.Count := Container.Count - Count;
end Delete_Subtree;
@ -804,6 +792,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
N := N.Parent;
Result := Result + 1;
end loop;
return Result;
end Depth;
@ -1122,10 +1111,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Parent => Parent.Node,
Before => Before.Node);
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Insert_Child;
@ -1144,11 +1132,10 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
C : Children_Type renames Parent.Children;
begin
-- This is a simple utility operation to
-- insert a list of nodes (from First..Last)
-- as children of Parent. The Before node
-- specifies where the new children should be
-- inserted relative to the existing children.
-- This is a simple utility operation to insert a list of nodes (from
-- First..Last) as children of Parent. The Before node specifies where
-- the new children should be inserted relative to the existing
-- children.
if First = null then
pragma Assert (Last = null);
@ -1194,8 +1181,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Before : Tree_Node_Access)
is
begin
-- This is a simple wrapper operation to insert
-- a single child into the Parent's children list.
-- This is a simple wrapper operation to insert a single child into the
-- Parent's children list.
Insert_Subtree_List
(First => Subtree,
@ -1282,6 +1269,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Process => Process);
B := B - 1;
exception
when others =>
B := B - 1;
@ -1315,6 +1303,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
end loop;
B := B - 1;
exception
when others =>
B := B - 1;
@ -1330,13 +1319,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Node : Tree_Node_Access;
begin
-- This is a helper function to recursively iterate over
-- all the nodes in a subtree, in depth-first fashion.
-- This particular helper just visits the children of this
-- subtree, not the root of the subtree node itself. This
-- is useful when starting from the ultimate root of the
-- entire tree (see Iterate), as that root does not have
-- an element.
-- This is a helper function to recursively iterate over all the nodes
-- in a subtree, in depth-first fashion. This particular helper just
-- visits the children of this subtree, not the root of the subtree node
-- itself. This is useful when starting from the ultimate root of the
-- entire tree (see Iterate), as that root does not have an element.
Node := Subtree.Children.First;
while Node /= null loop
@ -1366,12 +1353,12 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
if Is_Root (Position) then
Iterate_Children (Position.Container, Position.Node, Process);
else
Iterate_Subtree (Position.Container, Position.Node, Process);
end if;
B := B - 1;
exception
when others =>
B := B - 1;
@ -1385,10 +1372,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Process : not null access procedure (Position : Cursor))
is
begin
-- This is a helper function to recursively iterate over
-- all the nodes in a subtree, in depth-first fashion.
-- It first visits the root of the subtree, then visits
-- its children.
-- This is a helper function to recursively iterate over all the nodes
-- in a subtree, in depth-first fashion. It first visits the root of the
-- subtree, then visits its children.
Process (Cursor'(Container, Subtree));
Iterate_Children (Container, Subtree, Process);
@ -1484,17 +1470,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
function Node_Count (Container : Tree) return Count_Type is
begin
-- Container.Count is the number of nodes we have actually
-- allocated. We cache the value specifically so this Node_Count
-- operation can execute in O(1) time, which makes it behave
-- similarly to how the Length selector function behaves
-- for other containers.
-- Container.Count is the number of nodes we have actually allocated. We
-- cache the value specifically so this Node_Count operation can execute
-- in O(1) time, which makes it behave similarly to how the Length
-- selector function behaves for other containers.
--
-- The cached node count value only describes the nodes
-- we have allocated; the root node itself is not included
-- in that count. The Node_Count operation returns a value
-- that includes the root node (because the RM says so), so we
-- must add 1 to our cached value.
-- The cached node count value only describes the nodes we have
-- allocated; the root node itself is not included in that count. The
-- Node_Count operation returns a value that includes the root node
-- (because the RM says so), so we must add 1 to our cached value.
return 1 + Container.Count;
end Node_Count;
@ -1555,6 +1539,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Last := First;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Element := new Element_Type'(New_Item);
@ -1572,10 +1557,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Parent => Parent.Node,
Before => Parent.Node.Children.First);
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Prepend_Child;
@ -1632,6 +1616,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
@ -1653,7 +1638,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
function Read_Subtree
(Parent : Tree_Node_Access) return Tree_Node_Access;
Total_Count, Read_Count : Count_Type;
Total_Count : Count_Type;
Read_Count : Count_Type;
-------------------
-- Read_Children --
@ -1664,8 +1650,10 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
pragma Assert (Subtree.Children.First = null);
pragma Assert (Subtree.Children.Last = null);
Count : Count_Type; -- number of child subtrees
C : Children_Type;
Count : Count_Type;
-- Number of child subtrees
C : Children_Type;
begin
Count_Type'Read (Stream, Count);
@ -1687,8 +1675,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
C.Last := C.Last.Next;
end loop;
-- Now that the allocation and reads have completed successfully,
-- it is safe to link the children to their parent.
-- Now that the allocation and reads have completed successfully, it
-- is safe to link the children to their parent.
Subtree.Children := C;
end Read_Children;
@ -1759,8 +1747,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
C : Children_Type renames Subtree.Parent.Children;
begin
-- This is a utility operation to remove a subtree
-- node from its parent's list of children.
-- This is a utility operation to remove a subtree node from its
-- parent's list of children.
if C.First = Subtree then
pragma Assert (Subtree.Prev = null);
@ -1850,6 +1838,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
end loop;
B := B - 1;
exception
when others =>
B := B - 1;
@ -1954,10 +1943,10 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
with "attempt to tamper with cursors (Source tree is busy)";
end if;
-- We cache the count of the nodes we have allocated, so that
-- operation Node_Count can execute in O(1) time. But that means
-- we must count the nodes in the subtree we remove from Source
-- and insert into Target, in order to keep the count accurate.
-- We cache the count of the nodes we have allocated, so that operation
-- Node_Count can execute in O(1) time. But that means we must count the
-- nodes in the subtree we remove from Source and insert into Target, in
-- order to keep the count accurate.
Count := Subtree_Node_Count (Source_Parent.Node);
pragma Assert (Count >= 1);
@ -2041,13 +2030,13 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
C : Tree_Node_Access;
begin
-- This is a utility operation to remove the children from
-- Source parent and insert them into Target parent.
-- This is a utility operation to remove the children from Source parent
-- and insert them into Target parent.
Source_Parent.Children := Children_Type'(others => null);
-- Fix up the Parent pointers of each child to designate
-- its new Target parent.
-- Fix up the Parent pointers of each child to designate its new Target
-- parent.
C := CC.First;
while C /= null loop
@ -2140,17 +2129,16 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
with "attempt to tamper with cursors (Source tree is busy)";
end if;
-- This is an unfortunate feature of this API: we must count
-- the nodes in the subtree that we remove from the source tree,
-- which is an O(n) operation. It would have been better if
-- the Tree container did not have a Node_Count selector; a
-- user that wants the number of nodes in the tree could
-- simply call Subtree_Node_Count, with the understanding that
-- such an operation is O(n).
-- This is an unfortunate feature of this API: we must count the nodes
-- in the subtree that we remove from the source tree, which is an O(n)
-- operation. It would have been better if the Tree container did not
-- have a Node_Count selector; a user that wants the number of nodes in
-- the tree could simply call Subtree_Node_Count, with the understanding
-- that such an operation is O(n).
--
-- Of course, we could choose to implement the Node_Count selector
-- as an O(n) operation, which would turn this splice operation
-- into an O(1) operation. ???
-- Of course, we could choose to implement the Node_Count selector as an
-- O(n) operation, which would turn this splice operation into an O(1)
-- operation. ???
Subtree_Count := Subtree_Node_Count (Position.Node);
pragma Assert (Subtree_Count <= Source.Count);
@ -2200,7 +2188,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
end if;
if Is_Root (Position) then
-- Should this be PE instead? Need ARG confirmation. ???
raise Constraint_Error with "Position cursor designates root";
end if;
@ -2251,6 +2241,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Result := Result + Subtree_Node_Count (Node);
Node := Node.Next;
end loop;
return Result;
end Subtree_Node_Count;
@ -2340,6 +2331,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;

28
gcc/ada/a-cimutr.ads
View File

@ -231,8 +231,8 @@ package Ada.Containers.Indefinite_Multiway_Trees is
-- Parent : Cursor;
-- Process : not null access procedure (Position : Cursor));
--
-- It seems that the Container parameter is there by mistake, but
-- we need an official ruling from the ARG. ???
-- It seems that the Container parameter is there by mistake, but we need
-- an official ruling from the ARG. ???
procedure Iterate_Children
(Parent : Cursor;
@ -264,19 +264,17 @@ private
use Ada.Finalization;
-- The Count component of type Tree represents the number of
-- nodes that have been (dynamically) allocated. It does not
-- include the root node itself. As implementors, we decide
-- to cache this value, so that the selector function Node_Count
-- can execute in O(1) time, in order to be consistent with
-- the behavior of the Length selector function for other
-- standard container library units. This does mean, however,
-- that the two-container forms for Splice_XXX (that move subtrees
-- across tree containers) will execute in O(n) time, because
-- we must count the number of nodes in the subtree(s) that
-- get moved. (We resolve the tension between Node_Count
-- and Splice_XXX in favor of Node_Count, under the assumption
-- that Node_Count is the more common operation).
-- The Count component of type Tree represents the number of nodes that
-- have been (dynamically) allocated. It does not include the root node
-- itself. As implementors, we decide to cache this value, so that the
-- selector function Node_Count can execute in O(1) time, in order to be
-- consistent with the behavior of the Length selector function for other
-- standard container library units. This does mean, however, that the
-- two-container forms for Splice_XXX (that move subtrees across tree
-- containers) will execute in O(n) time, because we must count the number
-- of nodes in the subtree(s) that get moved. (We resolve the tension
-- between Node_Count and Splice_XXX in favor of Node_Count, under the
-- assumption that Node_Count is the more common operation).
type Tree is new Controlled with record
Root : aliased Tree_Node_Type;

308
gcc/ada/a-comutr.adb
View File

@ -133,25 +133,24 @@ package body Ada.Containers.Multiway_Trees is
Target_Count : Count_Type;
begin
-- We first restore the target container to its
-- default-initialized state, before we attempt any
-- allocation, to ensure that invariants are preserved
-- in the event that the allocation fails.
-- We first restore the target container to its default-initialized
-- state, before we attempt any allocation, to ensure that invariants
-- are preserved in the event that the allocation fails.
Container.Root.Children := Children_Type'(others => null);
Container.Busy := 0;
Container.Lock := 0;
Container.Count := 0;
-- Copy_Children returns a count of the number of nodes
-- that it allocates, but it works by incrementing the
-- value that is passed in. We must therefore initialize
-- the count value before calling Copy_Children.
-- Copy_Children returns a count of the number of nodes that it
-- allocates, but it works by incrementing the value that is passed
-- in. We must therefore initialize the count value before calling
-- Copy_Children.
Target_Count := 0;
-- Now we attempt the allocation of subtrees. The invariants
-- are satisfied even if the allocation fails.
-- Now we attempt the allocation of subtrees. The invariants are
-- satisfied even if the allocation fails.
Copy_Children (Source, Root_Node (Container), Target_Count);
pragma Assert (Target_Count = Source_Count);
@ -180,11 +179,10 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "Position cursor not in container";
end if;
-- AI-0136 says to raise PE if Position equals the root node.
-- This does not seem correct, as this value is just the limiting
-- condition of the search. For now we omit this check,
-- pending a ruling from the ARG. ???
--
-- AI-0136 says to raise PE if Position equals the root node. This does
-- not seem correct, as this value is just the limiting condition of the
-- search. For now we omit this check, pending a ruling from the ARG.???
-- if Is_Root (Position) then
-- raise Program_Error with "Position cursor designates root";
-- end if;
@ -238,7 +236,9 @@ package body Ada.Containers.Multiway_Trees is
Last := First;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
Prev => Last,
Element => New_Item,
@ -253,10 +253,9 @@ package body Ada.Containers.Multiway_Trees is
Parent => Parent.Node,
Before => null); -- null means "insert at end of list"
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Append_Child;
@ -276,16 +275,15 @@ package body Ada.Containers.Multiway_Trees is
Target.Clear; -- checks busy bit
-- Copy_Children returns the number of nodes that it allocates,
-- but it does this by incrementing the count value passed in,
-- so we must initialize the count before calling Copy_Children.
-- Copy_Children returns the number of nodes that it allocates, but it
-- does this by incrementing the count value passed in, so we must
-- initialize the count before calling Copy_Children.
Target_Count := 0;
-- Note that Copy_Children inserts the newly-allocated children
-- into their parent list only after the allocation of all the
-- children has succeeded. This preserves invariants even if
-- the allocation fails.
-- Note that Copy_Children inserts the newly-allocated children into
-- their parent list only after the allocation of all the children has
-- succeeded. This preserves invariants even if the allocation fails.
Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
pragma Assert (Target_Count = Source_Count);
@ -306,28 +304,25 @@ package body Ada.Containers.Multiway_Trees is
with "attempt to tamper with cursors (tree is busy)";
end if;
-- We first set the container count to 0, in order to
-- preserve invariants in case the deallocation fails.
-- (This works because Deallocate_Children immediately
-- removes the children from their parent, and then
-- does the actual deallocation.)
-- We first set the container count to 0, in order to preserve
-- invariants in case the deallocation fails. (This works because
-- Deallocate_Children immediately removes the children from their
-- parent, and then does the actual deallocation.)
Container_Count := Container.Count;
Container.Count := 0;
-- Deallocate_Children returns the number of nodes that
-- it deallocates, but it does this by incrementing the
-- count value that is passed in, so we must first initialize
-- the count return value before calling it.
-- Deallocate_Children returns the number of nodes that it deallocates,
-- but it does this by incrementing the count value that is passed in,
-- so we must first initialize the count return value before calling it.
Children_Count := 0;
-- See comment above. Deallocate_Children immediately
-- removes the children list from their parent node (here,
-- the root of the tree), and only after that does it
-- attempt the actual deallocation. So even if the
-- deallocation fails, the representation invariants
-- for the tree are preserved.
-- See comment above. Deallocate_Children immediately removes the
-- children list from their parent node (here, the root of the tree),
-- and only after that does it attempt the actual deallocation. So even
-- if the deallocation fails, the representation invariants for the tree
-- are preserved.
Deallocate_Children (Root_Node (Container), Children_Count);
pragma Assert (Children_Count = Container_Count);
@ -378,9 +373,8 @@ package body Ada.Containers.Multiway_Trees is
C : Tree_Node_Access;
begin
-- We special-case the first allocation, in order
-- to establish the representation invariants
-- for type Children_Type.
-- We special-case the first allocation, in order to establish the
-- representation invariants for type Children_Type.
C := Source.First;
@ -396,9 +390,8 @@ package body Ada.Containers.Multiway_Trees is
CC.Last := CC.First;
-- The representation invariants for the Children_Type
-- list have been established, so we can now copy
-- the remaining children of Source.
-- The representation invariants for the Children_Type list have been
-- established, so we can now copy the remaining children of Source.
C := C.Next;
while C /= null loop
@ -414,9 +407,8 @@ package body Ada.Containers.Multiway_Trees is
C := C.Next;
end loop;
-- We add the newly-allocated children to their parent list
-- only after the allocation has succeeded, in order to
-- preserve invariants of the parent.
-- Add the newly-allocated children to their parent list only after the
-- allocation has succeeded, so as to preserve invariants of the parent.
Parent.Children := CC;
end Copy_Children;
@ -445,6 +437,7 @@ package body Ada.Containers.Multiway_Trees is
Result := Result + 1;
Node := Node.Next;
end loop;
return Result;
end Child_Count;
@ -479,6 +472,7 @@ package body Ada.Containers.Multiway_Trees is
raise Program_Error with "Parent is not ancestor of Child";
end if;
end loop;
return Result;
end Child_Depth;
@ -522,10 +516,10 @@ package body Ada.Containers.Multiway_Trees is
raise Constraint_Error with "Source cursor designates root";
end if;
-- Copy_Subtree returns a count of the number of nodes
-- that it allocates, but it works by incrementing the
-- value that is passed in. We must therefore initialize
-- the count value before calling Copy_Subtree.
-- Copy_Subtree returns a count of the number of nodes that it
-- allocates, but it works by incrementing the value that is passed
-- in. We must therefore initialize the count value before calling
-- Copy_Subtree.
Target_Count := 0;
@ -544,10 +538,9 @@ package body Ada.Containers.Multiway_Trees is
Parent => Parent.Node,
Before => Before.Node);
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Target.Count := Target.Count + Target_Count;
end Copy_Subtree;
@ -585,9 +578,8 @@ package body Ada.Containers.Multiway_Trees is
C : Tree_Node_Access;
begin
-- We immediately remove the children from their
-- parent, in order to preserve invariants in case
-- the deallocation fails.
-- We immediately remove the children from their parent, in order to
-- preserve invariants in case the deallocation fails.
Subtree.Children := Children_Type'(others => null);
@ -637,10 +629,10 @@ package body Ada.Containers.Multiway_Trees is
with "attempt to tamper with cursors (tree is busy)";
end if;
-- Deallocate_Children returns a count of the number of nodes
-- that it deallocates, but it works by incrementing the
-- value that is passed in. We must therefore initialize
-- the count value before calling Deallocate_Children.
-- Deallocate_Children returns a count of the number of nodes that it
-- deallocates, but it works by incrementing the value that is passed
-- in. We must therefore initialize the count value before calling
-- Deallocate_Children.
Count := 0;
@ -685,16 +677,15 @@ package body Ada.Containers.Multiway_Trees is
X := Position.Node;
Position := No_Element;
-- Restore represention invariants before attempting the
-- actual deallocation.
-- Restore represention invariants before attempting the actual
-- deallocation.
Remove_Subtree (X);
Container.Count := Container.Count - 1;
-- It is now safe to attempt the deallocation. This leaf
-- node has been disassociated from the tree, so even if
-- the deallocation fails, representation invariants
-- will remain satisfied.
-- It is now safe to attempt the deallocation. This leaf node has been
-- disassociated from the tree, so even if the deallocation fails,
-- representation invariants will remain satisfied.
Deallocate_Node (X);
end Delete_Leaf;
@ -731,38 +722,35 @@ package body Ada.Containers.Multiway_Trees is
X := Position.Node;
Position := No_Element;
-- Here is one case where a deallocation failure can
-- result in the violation of a representation invariant.
-- We disassociate the subtree from the tree now, but we
-- only decrement the total node count after we attempt
-- the deallocation. However, if the deallocation fails,
-- the total node count will not get decremented.
--
-- One way around this dilemma is to count the nodes
-- in the subtree before attempt to delete the subtree,
-- but that is an O(n) operation, so it does not seem
-- worth it.
--
-- Perhaps this is much ado about nothing, since the
-- only way deallocation can fail is if Controlled
-- Finalization fails: this propagates Program_Error
-- so all bets are off anyway. ???
-- Here is one case where a deallocation failure can result in the
-- violation of a representation invariant. We disassociate the subtree
-- from the tree now, but we only decrement the total node count after
-- we attempt the deallocation. However, if the deallocation fails, the
-- total node count will not get decremented.
-- One way around this dilemma is to count the nodes in the subtree
-- before attempt to delete the subtree, but that is an O(n) operation,
-- so it does not seem worth it.
-- Perhaps this is much ado about nothing, since the only way
-- deallocation can fail is if Controlled Finalization fails: this
-- propagates Program_Error so all bets are off anyway. ???
Remove_Subtree (X);
-- Deallocate_Subtree returns a count of the number of nodes
-- that it deallocates, but it works by incrementing the
-- value that is passed in. We must therefore initialize
-- the count value before calling Deallocate_Subtree.
-- Deallocate_Subtree returns a count of the number of nodes that it
-- deallocates, but it works by incrementing the value that is passed
-- in. We must therefore initialize the count value before calling
-- Deallocate_Subtree.
Count := 0;
Deallocate_Subtree (X, Count);
pragma Assert (Count <= Container.Count);
-- See comments above. We would prefer to do this
-- sooner, but there's no way to satisfy that goal
-- without an potentially severe execution penalty.
-- See comments above. We would prefer to do this sooner, but there's no
-- way to satisfy that goal without a potentially severe execution
-- penalty.
Container.Count := Container.Count - Count;
end Delete_Subtree;
@ -782,6 +770,7 @@ package body Ada.Containers.Multiway_Trees is
N := N.Parent;
Result := Result + 1;
end loop;
return Result;
end Depth;
@ -1080,7 +1069,9 @@ package body Ada.Containers.Multiway_Trees is
Last := Position.Node;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
Prev => Last,
Element => New_Item,
@ -1095,10 +1086,9 @@ package body Ada.Containers.Multiway_Trees is
Parent => Parent.Node,
Before => Before.Node);
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Insert_Child;
@ -1149,7 +1139,9 @@ package body Ada.Containers.Multiway_Trees is
Last := Position.Node;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
Prev => Last,
Element => <>,
@ -1164,10 +1156,9 @@ package body Ada.Containers.Multiway_Trees is
Parent => Parent.Node,
Before => Before.Node);
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Insert_Child;
@ -1186,11 +1177,10 @@ package body Ada.Containers.Multiway_Trees is
C : Children_Type renames Parent.Children;
begin
-- This is a simple utility operation to
-- insert a list of nodes (from First..Last)
-- as children of Parent. The Before node
-- specifies where the new children should be
-- inserted relative to the existing children.
-- This is a simple utility operation to insert a list of nodes (from
-- First..Last) as children of Parent. The Before node specifies where
-- the new children should be inserted relative to the existing
-- children.
if First = null then
pragma Assert (Last = null);
@ -1236,8 +1226,8 @@ package body Ada.Containers.Multiway_Trees is
Before : Tree_Node_Access)
is
begin
-- This is a simple wrapper operation to insert
-- a single child into the Parent's children list.
-- This is a simple wrapper operation to insert a single child into the
-- Parent's children list.
Insert_Subtree_List
(First => Subtree,
@ -1324,6 +1314,7 @@ package body Ada.Containers.Multiway_Trees is
Process => Process);
B := B - 1;
exception
when others =>
B := B - 1;
@ -1357,6 +1348,7 @@ package body Ada.Containers.Multiway_Trees is
end loop;
B := B - 1;
exception
when others =>
B := B - 1;
@ -1372,13 +1364,11 @@ package body Ada.Containers.Multiway_Trees is
Node : Tree_Node_Access;
begin
-- This is a helper function to recursively iterate over
-- all the nodes in a subtree, in depth-first fashion.
-- This particular helper just visits the children of this
-- subtree, not the root of the subtree node itself. This
-- is useful when starting from the ultimate root of the
-- entire tree (see Iterate), as that root does not have
-- an element.
-- This is a helper function to recursively iterate over all the nodes
-- in a subtree, in depth-first fashion. This particular helper just
-- visits the children of this subtree, not the root of the subtree node
-- itself. This is useful when starting from the ultimate root of the
-- entire tree (see Iterate), as that root does not have an element.
Node := Subtree.Children.First;
while Node /= null loop
@ -1414,6 +1404,7 @@ package body Ada.Containers.Multiway_Trees is
end if;
B := B - 1;
exception
when others =>
B := B - 1;
@ -1427,10 +1418,9 @@ package body Ada.Containers.Multiway_Trees is
Process : not null access procedure (Position : Cursor))
is
begin
-- This is a helper function to recursively iterate over
-- all the nodes in a subtree, in depth-first fashion.
-- It first visits the root of the subtree, then visits
-- its children.
-- This is a helper function to recursively iterate over all the nodes
-- in a subtree, in depth-first fashion. It first visits the root of the
-- subtree, then visits its children.
Process (Cursor'(Container, Subtree));
Iterate_Children (Container, Subtree, Process);
@ -1526,17 +1516,15 @@ package body Ada.Containers.Multiway_Trees is
function Node_Count (Container : Tree) return Count_Type is
begin
-- Container.Count is the number of nodes we have actually
-- allocated. We cache the value specifically so this Node_Count
-- operation can execute in O(1) time, which makes it behave
-- similarly to how the Length selector function behaves
-- for other containers.
--
-- The cached node count value only describes the nodes
-- we have allocated; the root node itself is not included
-- in that count. The Node_Count operation returns a value
-- that includes the root node (because the RM says so), so we
-- must add 1 to our cached value.
-- Container.Count is the number of nodes we have actually allocated. We
-- cache the value specifically so this Node_Count operation can execute
-- in O(1) time, which makes it behave similarly to how the Length
-- selector function behaves for other containers.
-- The cached node count value only describes the nodes we have
-- allocated; the root node itself is not included in that count. The
-- Node_Count operation returns a value that includes the root node
-- (because the RM says so), so we must add 1 to our cached value.
return 1 + Container.Count;
end Node_Count;
@ -1595,7 +1583,9 @@ package body Ada.Containers.Multiway_Trees is
Last := First;
for J in Count_Type'(2) .. Count loop
-- Reclaim other nodes if Storage_Error. ???
Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
Prev => Last,
Element => New_Item,
@ -1610,10 +1600,9 @@ package body Ada.Containers.Multiway_Trees is
Parent => Parent.Node,
Before => Parent.Node.Children.First);
-- In order for operation Node_Count to complete
-- in O(1) time, we cache the count value. Here we
-- increment the total count by the number of nodes
-- we just inserted.
-- In order for operation Node_Count to complete in O(1) time, we cache
-- the count value. Here we increment the total count by the number of
-- nodes we just inserted.
Container.Count := Container.Count + Count;
end Prepend_Child;
@ -1670,6 +1659,7 @@ package body Ada.Containers.Multiway_Trees is
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
@ -1725,8 +1715,8 @@ package body Ada.Containers.Multiway_Trees is
C.Last := C.Last.Next;
end loop;
-- Now that the allocation and reads have completed successfully,
-- it is safe to link the children to their parent.
-- Now that the allocation and reads have completed successfully, it
-- is safe to link the children to their parent.
Subtree.Children := C;
end Read_Children;
@ -1878,6 +1868,7 @@ package body Ada.Containers.Multiway_Trees is
end loop;
B := B - 1;
exception
when others =>
B := B - 1;
@ -1909,11 +1900,11 @@ package body Ada.Containers.Multiway_Trees is
-- Start of processing for Root_Node
begin
-- This is a utility function for converting from an access type
-- that designates the distinguished root node to an access type
-- designating a non-root node. The representation of a root node
-- does not have an element, but is otherwise identical to a
-- non-root node, so the conversion itself is safe.
-- This is a utility function for converting from an access type that
-- designates the distinguished root node to an access type designating
-- a non-root node. The representation of a root node does not have an
-- element, but is otherwise identical to a non-root node, so the
-- conversion itself is safe.
return To_Tree_Node_Access (Container.Root'Unrestricted_Access);
end Root_Node;
@ -1997,10 +1988,10 @@ package body Ada.Containers.Multiway_Trees is
with "attempt to tamper with cursors (Source tree is busy)";
end if;
-- We cache the count of the nodes we have allocated, so that
-- operation Node_Count can execute in O(1) time. But that means
-- we must count the nodes in the subtree we remove from Source
-- and insert into Target, in order to keep the count accurate.
-- We cache the count of the nodes we have allocated, so that operation
-- Node_Count can execute in O(1) time. But that means we must count the
-- nodes in the subtree we remove from Source and insert into Target, in
-- order to keep the count accurate.
Count := Subtree_Node_Count (Source_Parent.Node);
pragma Assert (Count >= 1);
@ -2183,17 +2174,16 @@ package body Ada.Containers.Multiway_Trees is
with "attempt to tamper with cursors (Source tree is busy)";
end if;
-- This is an unfortunate feature of this API: we must count
-- the nodes in the subtree that we remove from the source tree,
-- which is an O(n) operation. It would have been better if
-- the Tree container did not have a Node_Count selector; a
-- user that wants the number of nodes in the tree could
-- simply call Subtree_Node_Count, with the understanding that
-- such an operation is O(n).
--
-- Of course, we could choose to implement the Node_Count selector
-- as an O(n) operation, which would turn this splice operation
-- into an O(1) operation. ???
-- This is an unfortunate feature of this API: we must count the nodes
-- in the subtree that we remove from the source tree, which is an O(n)
-- operation. It would have been better if the Tree container did not
-- have a Node_Count selector; a user that wants the number of nodes in
-- the tree could simply call Subtree_Node_Count, with the understanding
-- that such an operation is O(n).
-- Of course, we could choose to implement the Node_Count selector as an
-- O(n) operation, which would turn this splice operation into an O(1)
-- operation. ???
Subtree_Count := Subtree_Node_Count (Position.Node);
pragma Assert (Subtree_Count <= Source.Count);
@ -2243,7 +2233,9 @@ package body Ada.Containers.Multiway_Trees is
end if;
if Is_Root (Position) then
-- Should this be PE instead? Need ARG confirmation. ???
raise Constraint_Error with "Position cursor designates root";
end if;
@ -2294,6 +2286,7 @@ package body Ada.Containers.Multiway_Trees is
Result := Result + Subtree_Node_Count (Node);
Node := Node.Next;
end loop;
return Result;
end Subtree_Node_Count;
@ -2383,6 +2376,7 @@ package body Ada.Containers.Multiway_Trees is
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;

66
gcc/ada/a-comutr.ads
View File

@ -238,8 +238,8 @@ package Ada.Containers.Multiway_Trees is
-- Parent : Cursor;
-- Process : not null access procedure (Position : Cursor));
--
-- It seems that the Container parameter is there by mistake, but
-- we need an official ruling from the ARG. ???
-- It seems that the Container parameter is there by mistake, but we need
-- an official ruling from the ARG. ???
procedure Iterate_Children
(Parent : Cursor;
@ -251,29 +251,29 @@ package Ada.Containers.Multiway_Trees is
private
-- A node of this multiway tree comprises an element and a list of
-- children (that are themselves trees). The root node is distinguished
-- because it contains only children: it does not have an element itself.
-- A node of this multiway tree comprises an element and a list of children
-- (that are themselves trees). The root node is distinguished because it
-- contains only children: it does not have an element itself.
--
-- This design feature puts two design goals in tension:
-- (1) treat the root node the same as any other node
-- (2) not declare any objects of type Element_Type unnecessarily
--
-- To satisfy (1), we could simply declare the Root node of the tree
-- using the normal Tree_Node_Type, but that would mean that (2) is not
-- To satisfy (1), we could simply declare the Root node of the tree using
-- the normal Tree_Node_Type, but that would mean that (2) is not
-- satisfied. To resolve the tension (in favor of (2)), we declare the
-- component Root as having a different node type, without an Element
-- component (thus satisfying goal (2)) but otherwise identical to a
-- normal node, and then use Unchecked_Conversion to convert an access
-- object designating the Root node component to the access type
-- designating a normal, non-root node (thus satisfying goal (1)). We make
-- an explicit check for Root when there is any attempt to manipulate the
-- Element component of the node (a check required by the RM anyway).
-- component (thus satisfying goal (2)) but otherwise identical to a normal
-- node, and then use Unchecked_Conversion to convert an access object
-- designating the Root node component to the access type designating a
-- normal, non-root node (thus satisfying goal (1)). We make an explicit
-- check for Root when there is any attempt to manipulate the Element
-- component of the node (a check required by the RM anyway).
--
-- In order to be explicit about node (and pointer) representation, we
-- specify that the respective node types have convention C, to ensure
-- that the layout of the components of the node records is the same,
-- thus guaranteeing that (unchecked) conversions between access types
-- specify that the respective node types have convention C, to ensure that
-- the layout of the components of the node records is the same, thus
-- guaranteeing that (unchecked) conversions between access types
-- designating each kind of node type is a meaningful conversion.
type Tree_Node_Type;
@ -285,9 +285,8 @@ private
Last : Tree_Node_Access;
end record;
-- See the comment above. This declaration must exactly
-- match the declaration of Root_Node_Type (except for
-- the Element component).
-- See the comment above. This declaration must exactly match the
-- declaration of Root_Node_Type (except for the Element component).
type Tree_Node_Type is record
Parent : Tree_Node_Access;
@ -298,9 +297,8 @@ private
end record;
pragma Convention (C, Tree_Node_Type);
-- See the comment above. This declaration must match
-- the declaration of Tree_Node_Type (except for the
-- Element component).
-- See the comment above. This declaration must match the declaration of
-- Tree_Node_Type (except for the Element component).
type Root_Node_Type is record
Parent : Tree_Node_Access;
@ -312,19 +310,17 @@ private
use Ada.Finalization;
-- The Count component of type Tree represents the number of
-- nodes that have been (dynamically) allocated. It does not
-- include the root node itself. As implementors, we decide
-- to cache this value, so that the selector function Node_Count
-- can execute in O(1) time, in order to be consistent with
-- the behavior of the Length selector function for other
-- standard container library units. This does mean, however,
-- that the two-container forms for Splice_XXX (that move subtrees
-- across tree containers) will execute in O(n) time, because
-- we must count the number of nodes in the subtree(s) that
-- get moved. (We resolve the tension between Node_Count
-- and Splice_XXX in favor of Node_Count, under the assumption
-- that Node_Count is the more common operation).
-- The Count component of type Tree represents the number of nodes that
-- have been (dynamically) allocated. It does not include the root node
-- itself. As implementors, we decide to cache this value, so that the
-- selector function Node_Count can execute in O(1) time, in order to be
-- consistent with the behavior of the Length selector function for other
-- standard container library units. This does mean, however, that the
-- two-container forms for Splice_XXX (that move subtrees across tree
-- containers) will execute in O(n) time, because we must count the number
-- of nodes in the subtree(s) that get moved. (We resolve the tension
-- between Node_Count and Splice_XXX in favor of Node_Count, under the
-- assumption that Node_Count is the more common operation).
type Tree is new Controlled with record
Root : aliased Root_Node_Type;

16
gcc/ada/a-fihema.adb
View File

@ -67,11 +67,10 @@ package body Ada.Finalization.Heap_Management is
procedure Fin_Assert (Condition : Boolean; Message : String);
-- Asserts that the condition is True. Used instead of pragma Assert in
-- delicate places where raising an exception would cause re-invocation of
-- finalization. Instead of raising an exception, aborts the whole
-- process.
-- finalization. Instead of raising an exception, aborts the whole process.
function Is_Empty (Objects : Node_Ptr) return Boolean;
-- True if the Objects list is empty.
-- True if the Objects list is empty
----------------
-- Fin_Assert --
@ -194,6 +193,7 @@ package body Ada.Finalization.Heap_Management is
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
end Attach;
---------------
@ -279,8 +279,10 @@ package body Ada.Finalization.Heap_Management is
end if;
Unlock_Task.all;
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
end Detach;
--------------
@ -305,9 +307,12 @@ package body Ada.Finalization.Heap_Management is
-- modified.
if Collection.Finalization_Started then
-- ???Needed for shared libraries.
-- ???Needed for shared libraries
return;
end if;
pragma Debug (Fin_Assert (not Collection.Finalization_Started,
"Finalize: already started"));
Collection.Finalization_Started := True;
@ -340,7 +345,6 @@ package body Ada.Finalization.Heap_Management is
begin
Collection.Finalize_Address (Object_Address);
exception
when Fin_Except : others =>
if not Raised then
@ -403,7 +407,7 @@ package body Ada.Finalization.Heap_Management is
procedure pcol (Collection : Finalization_Collection) is
Head : constant Node_Ptr := Collection.Objects'Unrestricted_Access;
-- "Unrestricted", because we are getting access-to-variable of a
-- constant! Normally worrisome, this is OK for debugging code.
-- constant! Normally worrisome, this is OK for debugging code.
Head_Seen : Boolean := False;
N_Ptr : Node_Ptr;

39
gcc/ada/a-iteint.ads
View File

@ -6,27 +6,10 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
@ -34,13 +17,21 @@ generic
type Cursor is private;
No_Element : Cursor;
pragma Unreferenced (No_Element);
package Ada.Iterator_Interfaces is
type Forward_Iterator is limited interface;
function First (Object : Forward_Iterator) return Cursor is abstract;
function Next (Object : Forward_Iterator; Position : Cursor) return Cursor
is abstract;
function Next
(Object : Forward_Iterator;
Position : Cursor) return Cursor is abstract;
type Reversible_Iterator is limited interface and Forward_Iterator;
function Last (Object : Reversible_Iterator) return Cursor is abstract;
function Previous (Object : Reversible_Iterator; Position : Cursor)
return Cursor is abstract;
function Previous
(Object : Reversible_Iterator;
Position : Cursor) return Cursor is abstract;
end Ada.Iterator_Interfaces;

4
gcc/ada/exp_disp.adb
View File

@ -7870,8 +7870,8 @@ package body Exp_Disp is
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
Adjusted : Boolean := False;
Finalized : Boolean := False;
Adjusted : Boolean := False;
Finalized : Boolean := False;
Count_Prim : Nat;
DT_Length : Nat;

11
gcc/ada/lib-xref-alfa.adb
View File

@ -877,12 +877,11 @@ package body ALFA is
procedure Detect_And_Add_ALFA_Scope (N : Node_Id) is
begin
if Nkind_In (N,
N_Subprogram_Declaration,
N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Package_Declaration,
N_Package_Body)
if Nkind_In (N, N_Subprogram_Declaration,
N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Package_Declaration,
N_Package_Body)
then
Add_ALFA_Scope (N);
end if;

3
gcc/ada/lib-xref.adb
View File

@ -174,7 +174,8 @@ package body Lib.Xref is
when N_Pragma =>
if Get_Pragma_Id (Result) = Pragma_Precondition
or else Get_Pragma_Id (Result) = Pragma_Postcondition
or else
Get_Pragma_Id (Result) = Pragma_Postcondition
then
return Empty;
else

10
gcc/ada/par_sco.adb
View File

@ -893,6 +893,7 @@ package body Par_SCO is
if Index /= 0 then
declare
T : SCO_Table_Entry renames SCO_Table.Table (Index);
begin
-- Called multiple times for the same sloc (need to allow for
-- C2 = 'P') ???
@ -1080,7 +1081,7 @@ package body Par_SCO is
SCE : SC_Entry renames SC.Table (J);
Pragma_Sloc : Source_Ptr := No_Location;
begin
-- For the statement SCO for a pragma controlled by
-- For the case of a statement SCO for a pragma controlled by
-- Set_SCO_Pragma_Enable, set Pragma_Sloc so that the SCO (and
-- those of any nested decision) is emitted only if the pragma
-- is enabled.
@ -1506,10 +1507,9 @@ package body Par_SCO is
when N_Generic_Instantiation =>
Typ := 'i';
when
N_Representation_Clause |
N_Use_Package_Clause |
N_Use_Type_Clause =>
when N_Representation_Clause |
N_Use_Package_Clause |
N_Use_Type_Clause =>
Typ := ASCII.NUL;
when others =>

2
gcc/ada/scos.ads
View File

@ -339,7 +339,7 @@ package SCOs is
-- Disabled pragmas
-- No SCO is generated for disabled pragmas.
-- No SCO is generated for disabled pragmas
---------------------------------------------------------------------
-- Internal table used to store Source Coverage Obligations (SCOs) --

47
gcc/ada/sem_ch11.adb
View File

@ -432,6 +432,7 @@ package body Sem_Ch11 is
Exception_Id : constant Node_Id := Name (N);
Exception_Name : Entity_Id := Empty;
P : Node_Id;
Par : Node_Id;
begin
Check_SPARK_Restriction ("raise statement is not allowed", N);
@ -443,9 +444,9 @@ package body Sem_Ch11 is
Check_Restriction (No_Exceptions, N);
end if;
-- Check for useless assignment to OUT or IN OUT scalar immediately
-- preceding the raise. Right now we only look at assignment statements,
-- we could do more.
-- Check for useless assignment to OUT or IN OUT scalar preceding the
-- raise. Right now we only look at assignment statements, we could do
-- more.
if Is_List_Member (N) then
declare
@ -455,21 +456,49 @@ package body Sem_Ch11 is
begin
P := Prev (N);
-- Skip past null statements and pragmas
while Present (P)
and then Nkind_In (P, N_Null_Statement, N_Pragma)
loop
P := Prev (P);
end loop;
-- See if preceding statement is an assignment
if Present (P)
and then Nkind (P) = N_Assignment_Statement
then
L := Name (P);
-- Give warning for assignment to scalar formal
if Is_Scalar_Type (Etype (L))
and then Is_Entity_Name (L)
and then Is_Formal (Entity (L))
then
Error_Msg_N
("?assignment to pass-by-copy formal may have no effect",
P);
Error_Msg_N
("\?RAISE statement may result in abnormal return" &
" (RM 6.4.1(17))", P);
-- Don't give warning if we are covered by an exception
-- handler, since this may result in false positives, since
-- the handler may handle the exception and return normally.
-- First find enclosing sequence of statements
Par := N;
loop
Par := Parent (Par);
exit when Nkind (Par) = N_Handled_Sequence_Of_Statements;
end loop;
-- See if there is a handler, give message if not
if No (Exception_Handlers (Par)) then
Error_Msg_N
("?assignment to pass-by-copy formal " &
"may have no effect", P);
Error_Msg_N
("\?RAISE statement may result in abnormal return" &
" (RM 6.4.1(17))", P);
end if;
end if;
end if;
end;

36
gcc/ada/sem_ch12.adb
View File

@ -3402,14 +3402,14 @@ package body Sem_Ch12 is
and then not Inline_Now
and then not ALFA_Mode
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode));
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode));
-- If front_end_inlining is enabled, do not instantiate body if
-- within a generic context.
if (Front_End_Inlining
and then not Expander_Active)
and then not Expander_Active)
or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
then
Needs_Body := False;
@ -3430,10 +3430,10 @@ package body Sem_Ch12 is
begin
if Nkind (Decl) = N_Formal_Package_Declaration
or else (Nkind (Decl) = N_Package_Declaration
and then Is_List_Member (Decl)
and then Present (Next (Decl))
and then
Nkind (Next (Decl)) =
and then Is_List_Member (Decl)
and then Present (Next (Decl))
and then
Nkind (Next (Decl)) =
N_Formal_Package_Declaration)
then
Needs_Body := False;
@ -4014,12 +4014,12 @@ package body Sem_Ch12 is
is
begin
if (Is_In_Main_Unit (N)
or else Is_Inlined (Subp)
or else Is_Inlined (Alias (Subp)))
or else Is_Inlined (Subp)
or else Is_Inlined (Alias (Subp)))
and then not ALFA_Mode
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode))
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode))
and then (Expander_Active or else ASIS_Mode)
and then not ABE_Is_Certain (N)
and then not Is_Eliminated (Subp)
@ -4033,6 +4033,7 @@ package body Sem_Ch12 is
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version));
return True;
else
return False;
end if;
@ -11892,14 +11893,13 @@ package body Sem_Ch12 is
if Present (E) then
-- If the node is an entry call to an entry in an enclosing task,
-- it is rewritten as a selected component. No global entity
-- to preserve in this case, the expansion will be redone in the
-- instance.
-- it is rewritten as a selected component. No global entity to
-- preserve in this case, since the expansion will be redone in
-- the instance.
if not Nkind_In (E,
N_Defining_Identifier,
N_Defining_Character_Literal,
N_Defining_Operator_Symbol)
if not Nkind_In (E, N_Defining_Identifier,
N_Defining_Character_Literal,
N_Defining_Operator_Symbol)
then
Set_Associated_Node (N, Empty);
Set_Etype (N, Empty);

22
gcc/ada/sem_ch3.adb
View File

@ -4243,24 +4243,24 @@ package body Sem_Ch3 is
end if;
when Private_Kind =>
Set_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_First_Entity (Id, First_Entity (T));
Set_Last_Entity (Id, Last_Entity (T));
Set_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_First_Entity (Id, First_Entity (T));
Set_Last_Entity (Id, Last_Entity (T));
Set_Private_Dependents (Id, New_Elmt_List);
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Implicit_Dereference
(Id, Has_Implicit_Dereference (T));
(Id, Has_Implicit_Dereference (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
(Id, Has_Unknown_Discriminants (T));
Set_Known_To_Have_Preelab_Init
(Id, Known_To_Have_Preelab_Init (T));
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Direct_Primitive_Operations (Id,
Direct_Primitive_Operations (T));
end if;
@ -4273,14 +4273,14 @@ package body Sem_Ch3 is
if Has_Discriminants (T) then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (T));
(Id, Discriminant_Constraint (T));
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
elsif Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (Full_View (T)));
(Id, Discriminant_Constraint (Full_View (T)));
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
-- This would seem semantically correct, but apparently

7
gcc/ada/sem_ch4.adb
View File

@ -6303,26 +6303,27 @@ package body Sem_Ch4 is
Func_Name := Empty;
Is_Var := False;
Ritem := First_Rep_Item (Etype (Prefix));
Ritem := First_Rep_Item (Etype (Prefix));
while Present (Ritem) loop
if Nkind (Ritem) = N_Aspect_Specification then
-- Prefer Variable_Indexing, but will settle for Constant.
if Get_Aspect_Id (Chars (Identifier (Ritem))) =
Aspect_Constant_Indexing
Aspect_Constant_Indexing
then
Func_Name := Expression (Ritem);
elsif Get_Aspect_Id (Chars (Identifier (Ritem))) =
Aspect_Variable_Indexing
Aspect_Variable_Indexing
then
Func_Name := Expression (Ritem);
Is_Var := True;
exit;
end if;
end if;
Next_Rep_Item (Ritem);
end loop;

8
gcc/ada/sem_res.adb
View File

@ -1756,7 +1756,7 @@ package body Sem_Res is
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id);
-- AI05-139 : names with implicit dereference. If the expression N is a
-- AI05-139: Names with implicit dereference. If the expression N is a
-- reference type and the context imposes the corresponding designated
-- type, convert N into N.Disc.all. Such expressions are always over-
-- loaded with both interpretations, and the dereference interpretation
@ -2312,9 +2312,9 @@ package body Sem_Res is
elsif Nkind (N) = N_Conditional_Expression then
Set_Etype (N, Expr_Type);
-- AI05-0139-2 : expression is overloaded because
-- type has implicit dereference. If type matches
-- context, no implicit dereference is involved.
-- AI05-0139-2: Expression is overloaded because type has
-- implicit dereference. If type matches context, no implicit
-- dereference is involved.
elsif Has_Implicit_Dereference (Expr_Type) then
Set_Etype (N, Expr_Type);

2
gcc/ada/sem_util.ads
View File

@ -148,7 +148,7 @@ package Sem_Util is
-- means that for sure CE cannot be raised.
procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id);
-- AI05-139-2 : accessors and iterators for containers. This procedure
-- AI05-139-2: Accessors and iterators for containers. This procedure
-- checks whether T is a reference type, and if so it adds an interprettion
-- to Expr whose type is the designated type of the reference_discriminant.