+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.
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);
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;
Last := First;
for J in Count_Type'(2) .. Count loop
+
-- Reclaim other nodes if Storage_Error. ???
Element := new Element_Type'(New_Item);
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;
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);
-----------
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
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);
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;
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
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;
Result := Result + 1;
Node := Node.Next;
end loop;
+
return Result;
end Child_Count;
raise Program_Error with "Parent is not ancestor of Child";
end if;
end loop;
+
return Result;
end Child_Depth;
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;
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;
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);
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;
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;
N := N.Parent;
Result := Result + 1;
end loop;
+
return Result;
end Depth;
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;
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);
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,
Process => Process);
B := B - 1;
+
exception
when others =>
B := B - 1;
end loop;
B := B - 1;
+
exception
when others =>
B := B - 1;
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
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;
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);
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;
Last := First;
for J in Count_Type'(2) .. Count loop
+
-- Reclaim other nodes if Storage_Error. ???
Element := new Element_Type'(New_Item);
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;
L := L - 1;
B := B - 1;
+
exception
when others =>
L := L - 1;
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 --
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);
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;
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);
end loop;
B := B - 1;
+
exception
when others =>
B := B - 1;
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);
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
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);
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;
Result := Result + Subtree_Node_Count (Node);
Node := Node.Next;
end loop;
+
return Result;
end Subtree_Node_Count;
L := L - 1;
B := B - 1;
+
exception
when others =>
L := L - 1;
-- 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;
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;
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);
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;
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,
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;
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);
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);
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;
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
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;
Result := Result + 1;
Node := Node.Next;
end loop;
+
return Result;
end Child_Count;
raise Program_Error with "Parent is not ancestor of Child";
end if;
end loop;
+
return Result;
end Child_Depth;
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;
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;
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);
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;
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;
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;
N := N.Parent;
Result := Result + 1;
end loop;
+
return Result;
end Depth;
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,
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;
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 => <>,
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;
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);
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,
Process => Process);
B := B - 1;
+
exception
when others =>
B := B - 1;
end loop;
B := B - 1;
+
exception
when others =>
B := B - 1;
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
end if;
B := B - 1;
+
exception
when others =>
B := B - 1;
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);
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;
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,
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;
L := L - 1;
B := B - 1;
+
exception
when others =>
L := L - 1;
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;
end loop;
B := B - 1;
+
exception
when others =>
B := B - 1;
-- 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;
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);
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);
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;
Result := Result + Subtree_Node_Count (Node);
Node := Node.Next;
end loop;
+
return Result;
end Subtree_Node_Count;
L := L - 1;
B := B - 1;
+
exception
when others =>
L := L - 1;
-- 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;
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;
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;
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;
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;
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 --
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
+
end Attach;
---------------
end if;
Unlock_Task.all;
+
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
+
end Detach;
--------------
-- 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;
begin
Collection.Finalize_Address (Object_Address);
-
exception
when Fin_Except : others =>
if not Raised then
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;
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
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;
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;
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;
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
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') ???
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.
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 =>
-- 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) --
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);
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
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;
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;
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;
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)
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version));
return True;
+
else
return False;
end if;
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.
-
- if not Nkind_In (E,
- N_Defining_Identifier,
- N_Defining_Character_Literal,
- N_Defining_Operator_Symbol)
+ -- 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)
then
Set_Associated_Node (N, Empty);
Set_Etype (N, Empty);
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;
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
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;
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
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);
-- 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.
projects / platform / upstream / linaro-gcc.git / commitdiff