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

[multiple changes] 

2011-09-15  Robert Dewar  <dewar@adacore.com>

	* a-cdlili.adb, a-coinve.adb, a-stzunb-shared.ads, a-suezst.adb,
	a-suenco.adb, a-stwiun-shared.ads, a-cobove.adb, a-convec.adb,
	a-btgbso.adb, a-cbdlli.adb, a-suewst.adb: Minor reformatting.

2011-09-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Expression_Function): Code cleanup:
	if the expression function is not a completion, create a
	new specification for the generated declaration, and keep the
	original specification in the generated body. Shorter code also
	ensures that proper warnings are generated for unused formals
	in all cases.

2011-09-15  Sergey Rybin  <rybin@adacore.com>

	* tree_io.ads: Update ASIS_Version_Number because of the changes
	in the tree structures for expression functions.

2011-09-15  Arnaud Charlet  <charlet@adacore.com>

	* s-osinte-aix.ads, s-osinte-darwin.ads, s-osinte-freebsd.ads,
	s-osinte-hpux.ads, s-osinte-lynxos.ads, s-osinte-solaris-posix.ads,
	s-taprop-posix.adb (CLOCK_MONOTONIC): New constant.
	(CLOCK_REALTIME): Fix wrong value on some OSes.
	* s-taprop-posix.adb (Monotonic_Clock): Use CLOCK_MONOTONIC.

From-SVN: r178877
This commit is contained in:
Arnaud Charlet 2011-09-15 12:22:54 +02:00
parent 21f1e8ce72
commit 0b5b2bbc71
21 changed files with 292 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
gcc/ada/ChangeLog
View File

@ -1,3 +1,31 @@
2011-09-15 Robert Dewar <dewar@adacore.com>
* a-cdlili.adb, a-coinve.adb, a-stzunb-shared.ads, a-suezst.adb,
a-suenco.adb, a-stwiun-shared.ads, a-cobove.adb, a-convec.adb,
a-btgbso.adb, a-cbdlli.adb, a-suewst.adb: Minor reformatting.
2011-09-15 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Expression_Function): Code cleanup:
if the expression function is not a completion, create a
new specification for the generated declaration, and keep the
original specification in the generated body. Shorter code also
ensures that proper warnings are generated for unused formals
in all cases.
2011-09-15 Sergey Rybin <rybin@adacore.com>
* tree_io.ads: Update ASIS_Version_Number because of the changes
in the tree structures for expression functions.
2011-09-15 Arnaud Charlet <charlet@adacore.com>
* s-osinte-aix.ads, s-osinte-darwin.ads, s-osinte-freebsd.ads,
s-osinte-hpux.ads, s-osinte-lynxos.ads, s-osinte-solaris-posix.ads,
s-taprop-posix.adb (CLOCK_MONOTONIC): New constant.
(CLOCK_REALTIME): Fix wrong value on some OSes.
* s-taprop-posix.adb (Monotonic_Clock): Use CLOCK_MONOTONIC.
2011-09-11 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/utils.c (maybe_unconstrained_array): In the reference

11
gcc/ada/a-btgbso.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -546,11 +546,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
"attempt to tamper with cursors (container is busy)";
end if;
-- Note that there's no way to decide a priori whether the
-- target has enough capacity for the union with source.
-- We cannot simply compare the sum of the existing lengths
-- to the capacity of the target, because equivalent items
-- from source are not included in the union.
-- Note that there's no way to decide a priori whether the target has
-- enough capacity for the union with source. We cannot simply compare
-- the sum of the existing lengths to the capacity of the target,
-- because equivalent items from source are not included in the union.
Iterate (Source);
end Set_Union;

103
gcc/ada/a-cbdlli.adb
View File

@ -582,52 +582,52 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
-- The list container actually contains two lists: one for the "active"
-- nodes that contain elements that have been inserted onto the list,
-- and another for the "inactive" nodes for the free store.
--
-- We desire that merely declaring an object should have only minimal
-- cost; specially, we want to avoid having to initialize the free
-- store (to fill in the links), especially if the capacity is large.
--
-- The head of the free list is indicated by Container.Free. If its
-- value is non-negative, then the free store has been initialized
-- in the "normal" way: Container.Free points to the head of the list
-- of free (inactive) nodes, and the value 0 means the free list is
-- empty. Each node on the free list has been initialized to point
-- to the next free node (via its Next component), and the value 0
-- means that this is the last free node.
--
-- If Container.Free is negative, then the links on the free store
-- have not been initialized. In this case the link values are
-- implied: the free store comprises the components of the node array
-- started with the absolute value of Container.Free, and continuing
-- until the end of the array (Nodes'Last).
--
-- If the list container is manipulated on one end only (for example
-- if the container were being used as a stack), then there is no
-- need to initialize the free store, since the inactive nodes are
-- physically contiguous (in fact, they lie immediately beyond the
-- logical end being manipulated). The only time we need to actually
-- initialize the nodes in the free store is if the node that becomes
-- inactive is not at the end of the list. The free store would then
-- be discontiguous and so its nodes would need to be linked in the
-- traditional way.
--
-- value is non-negative, then the free store has been initialized in
-- the "normal" way: Container.Free points to the head of the list of
-- free (inactive) nodes, and the value 0 means the free list is empty.
-- Each node on the free list has been initialized to point to the next
-- free node (via its Next component), and the value 0 means that this
-- is the last free node.
-- If Container.Free is negative, then the links on the free store have
-- not been initialized. In this case the link values are implied: the
-- free store comprises the components of the node array started with
-- the absolute value of Container.Free, and continuing until the end of
-- the array (Nodes'Last).
-- If the list container is manipulated on one end only (for example if
-- the container were being used as a stack), then there is no need to
-- initialize the free store, since the inactive nodes are physically
-- contiguous (in fact, they lie immediately beyond the logical end
-- being manipulated). The only time we need to actually initialize the
-- nodes in the free store is if the node that becomes inactive is not
-- at the end of the list. The free store would then be discontiguous
-- and so its nodes would need to be linked in the traditional way.
-- ???
-- It might be possible to perform an optimization here. Suppose that
-- the free store can be represented as having two parts: one
-- comprising the non-contiguous inactive nodes linked together
-- in the normal way, and the other comprising the contiguous
-- inactive nodes (that are not linked together, at the end of the
-- nodes array). This would allow us to never have to initialize
-- the free store, except in a lazy way as nodes become inactive.
-- the free store can be represented as having two parts: one comprising
-- the non-contiguous inactive nodes linked together in the normal way,
-- and the other comprising the contiguous inactive nodes (that are not
-- linked together, at the end of the nodes array). This would allow us
-- to never have to initialize the free store, except in a lazy way as
-- nodes become inactive.
-- When an element is deleted from the list container, its node
-- becomes inactive, and so we set its Prev component to a negative
-- value, to indicate that it is now inactive. This provides a useful
-- way to detect a dangling cursor reference.
-- When an element is deleted from the list container, its node becomes
-- inactive, and so we set its Prev component to a negative value, to
-- indicate that it is now inactive. This provides a useful way to
-- detect a dangling cursor reference.
N (X).Prev := -1; -- Node is deallocated (not on active list)
if Container.Free >= 0 then
-- The free store has previously been initialized. All we need to
-- do here is link the newly-free'd node onto the free list.
@ -635,11 +635,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Container.Free := X;
elsif X + 1 = abs Container.Free then
-- The free store has not been initialized, and the node becoming
-- inactive immediately precedes the start of the free store. All
-- we need to do is move the start of the free store back by one.
N (X).Next := 0; -- Not strictly necessary, but marginally safer
N (X).Next := 0; -- not strictly necessary, but marginally safer
Container.Free := Container.Free + 1;
else
@ -650,11 +651,10 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
-- node onto the head of the free store.
-- ???
-- See the comments above for an optimization opportunity. If
-- the next link for a node on the free store is negative, then
-- this means the remaining nodes on the free store are
-- physically contiguous, starting as the absolute value of
-- that index value.
-- See the comments above for an optimization opportunity. If the
-- next link for a node on the free store is negative, then this
-- means the remaining nodes on the free store are physically
-- contiguous, starting as the absolute value of that index value.
Container.Free := abs Container.Free;
@ -689,7 +689,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Node : Count_Type := Container.First;
begin
for I in 2 .. Container.Length loop
for J in 2 .. Container.Length loop
if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
return False;
end if;
@ -766,17 +766,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
N : Node_Array renames Container.Nodes;
procedure Partition (Pivot, Back : Count_Type);
-- What does this do ???
procedure Sort (Front, Back : Count_Type);
-- Internal procedure, what does it do??? rename it???
---------------
-- Partition --
---------------
procedure Partition (Pivot, Back : Count_Type) is
Node : Count_Type := N (Pivot).Next;
Node : Count_Type;
begin
Node := N (Pivot).Next;
while Node /= Back loop
if N (Node).Element < N (Pivot).Element then
declare
@ -2066,21 +2069,21 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return False;
end if;
if Position.Node = L.First then -- eliminates earlier disjunct
-- Eliminate earlier disjunct
if Position.Node = L.First then
return True;
end if;
-- If we get here, we know, per disjunctive syllogism (modus
-- tollendo ponens), that this predicate is true:
-- N (Position.Node).Prev /= 0
-- If we get here, we know (disjunctive syllogism) that this
-- predicate is true: N (Position.Node).Prev /= 0
if Position.Node = L.Last then -- eliminates earlier disjunct
return True;
end if;
-- If we get here, we know, per disjunctive syllogism (modus
-- tollendo ponens), that this predicate is true:
-- N (Position.Node).Next /= 0
-- If we get here, we know (disjunctive syllogism) that this
-- predicate is true: N (Position.Node).Next /= 0
if N (N (Position.Node).Next).Prev /= Position.Node then
return False;

18
gcc/ada/a-cdlili.adb
View File

@ -1890,21 +1890,23 @@ package body Ada.Containers.Doubly_Linked_Lists is
return False;
end if;
if Position.Node = L.First then -- eliminates earlier disjunct
-- Eliminate earlier disjunct
if Position.Node = L.First then
return True;
end if;
-- If we get here, we know, per disjunctive syllogism (modus
-- tollendo ponens), that this predicate is true:
-- Position.Node.Prev /= null
-- If we get here, we know (disjunctive syllogism) that this
-- predicate is true: Position.Node.Prev /= null
if Position.Node = L.Last then -- eliminates earlier disjunct
-- Eliminate earlier disjunct
if Position.Node = L.Last then
return True;
end if;
-- If we get here, we know, per disjunctive syllogism (modus
-- tollendo ponens), that this predicate is true:
-- Position.Node.Next /= null
-- If we get here, we know (disjunctive syllogism) that this
-- predicate is true: Position.Node.Next /= null
if Position.Node.Next.Prev /= Position.Node then
return False;

4
gcc/ada/a-cobove.adb
View File

@ -1394,8 +1394,8 @@ package body Ada.Containers.Bounded_Vectors is
-- There are two constraints we need to satisfy. The first constraint is
-- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the current length and the insertion
-- count. Note that we cannot simply add these values, because of the
-- we must check the sum of the current length and the insertion count.
-- Note that we cannot simply add these values, because of the
-- possibility of overflow.
if Old_Length > Count_Type'Last - Count then

159
gcc/ada/a-coinve.adb
View File

@ -651,6 +651,41 @@ package body Ada.Containers.Indefinite_Vectors is
end loop;
end Clear;
------------------------
-- Constant_Reference --
------------------------
function Constant_Reference
(Container : Vector;
Position : Cursor) return Constant_Reference_Type
is
begin
pragma Unreferenced (Container);
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
return
(Element => Position.Container.Elements.EA (Position.Index).all'Access);
end Constant_Reference;
function Constant_Reference
(Container : Vector;
Position : Index_Type) return Constant_Reference_Type
is
begin
if (Position) > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
return (Element => Container.Elements.EA (Position).all'Access);
end Constant_Reference;
--------------
-- Contains --
--------------
@ -1365,8 +1400,8 @@ package body Ada.Containers.Indefinite_Vectors is
-- There are two constraints we need to satisfy. The first constraint is
-- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the current length and the insertion
-- count. Note that we cannot simply add these values, because of the
-- we must check the sum of the current length and the insertion count.
-- Note that we cannot simply add these values, because of the
-- possibility of overflow.
if Old_Length > Count_Type'Last - Count then
@ -1385,10 +1420,12 @@ package body Ada.Containers.Indefinite_Vectors is
-- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is
-- less than 0, so it is safe to compute the following sum without
-- fear of overflow.
@ -1396,6 +1433,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
@ -1420,6 +1458,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
elsif Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is less
-- than 0, so it is safe to compute the following sum without fear of
-- overflow.
@ -1427,6 +1466,7 @@ package body Ada.Containers.Indefinite_Vectors is
J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the maximum
-- number of items that are allowed.
@ -1491,6 +1531,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- allocate the elements.
for Idx in Container.Elements.EA'Range loop
-- In order to preserve container invariants, we always attempt
-- the element allocation first, before setting the Last index
-- value, in case the allocation fails (either because there is no
@ -1519,6 +1560,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
if New_Length <= Container.Elements.EA'Length then
-- In this case, we're inserting elements into a vector that has
-- already allocated an internal array, and the existing array has
-- enough unused storage for the new items.
@ -1529,10 +1571,12 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Before > Container.Last then
-- The new items are being appended to the vector, so no
-- sliding of existing elements is required.
for Idx in Before .. New_Last loop
-- In order to preserve container invariants, we always
-- attempt the element allocation first, before setting the
-- Last index value, in case the allocation fails (either
@ -1556,7 +1600,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
@ -1622,6 +1665,7 @@ package body Ada.Containers.Indefinite_Vectors is
end loop;
if New_Capacity > Max_Length then
-- We have reached the limit of capacity, so no further expansion
-- will occur. (This is not a problem, as there is never a need to
-- have more capacity than the maximum container length.)
@ -1659,6 +1703,7 @@ package body Ada.Containers.Indefinite_Vectors is
Src.EA (Index_Type'First .. Before - 1);
if Before > Container.Last then
-- The new items are being appended to the vector, so no
-- sliding of existing elements is required.
@ -1672,6 +1717,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- Now we append the new items.
for Idx in Before .. New_Last loop
-- In order to preserve container invariants, we always
-- attempt the element allocation first, before setting the
-- Last index value, in case the allocation fails (either
@ -1712,6 +1758,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- items.
for Idx in Before .. Index - 1 loop
-- Note that container invariants have already been satisfied
-- (in particular, the Last index value of the vector has
-- already been updated), so if this allocation fails we simply
@ -1738,6 +1785,7 @@ package body Ada.Containers.Indefinite_Vectors is
Insert_Space (Container, Before, Count => N);
if N = 0 then
-- There's nothing else to do here (vetting of parameters was
-- performed already in Insert_Space), so we simply return.
@ -1745,6 +1793,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
if Container'Address /= New_Item'Address then
-- This is the simple case. New_Item denotes an object different
-- from Container, so there's nothing special we need to do to copy
-- the source items to their destination, because all of the source
@ -1812,6 +1861,7 @@ package body Ada.Containers.Indefinite_Vectors is
end loop;
if Src'Length = N then
-- The new items were effectively appended to the container, so we
-- have already copied all of the items that need to be copied.
-- We return early here, even though the source slice below is
@ -1824,12 +1874,11 @@ package body Ada.Containers.Indefinite_Vectors is
end;
-- Index value J is the first index of the second source slice. (It is
-- also 1 greater than the last index of the destination slice.) Note
-- that we want to avoid computing J, if J is greater than
-- Index_Type'Base'Last, in order to avoid overflow. We prevent that by
-- returning early above, immediately after copying the first slice of
-- the source, and determining that this second slice of the source is
-- empty.
-- also 1 greater than the last index of the destination slice.) Note:
-- avoid computing J if J is greater than Index_Type'Base'Last, in order
-- to avoid overflow. Prevent that by returning early above, immediately
-- after copying the first slice of the source, and determining that
-- this second slice of the source is empty.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
J := Before + Index_Type'Base (N);
@ -1850,11 +1899,10 @@ package body Ada.Containers.Indefinite_Vectors is
Dst_Index : Index_Type'Base;
begin
-- We next copy the source items that follow the space we
-- inserted. Index value Dst_Index is the first index of that portion
-- of the destination that receives this slice of the source. (For
-- the reasons given above, this slice is guaranteed to be
-- non-empty.)
-- We next copy the source items that follow the space we inserted.
-- Index value Dst_Index is the first index of that portion of the
-- destination that receives this slice of the source. (For the
-- reasons given above, this slice is guaranteed to be non-empty.)
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Index := J - Index_Type'Base (Src'Length);
@ -2122,6 +2170,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is
-- less than 0, so it is safe to compute the following sum without
-- fear of overflow.
@ -2129,6 +2178,7 @@ package body Ada.Containers.Indefinite_Vectors is
Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
@ -2153,6 +2203,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
elsif Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is less
-- than 0, so it is safe to compute the following sum without fear of
-- overflow.
@ -2160,6 +2211,7 @@ package body Ada.Containers.Indefinite_Vectors is
J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the maximum
-- number of items that are allowed.
@ -2216,9 +2268,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- In an indefinite vector, elements are allocated individually, and
-- stored as access values on the internal array (the length of which
-- represents the vector "capacity"), which is separately
-- allocated. We have no elements here (because we're inserting
-- "space"), so all we need to do is allocate the backbone.
-- represents the vector "capacity"), which is separately allocated.
-- We have no elements here (because we're inserting "space"), so all
-- we need to do is allocate the backbone.
Container.Elements := new Elements_Type (New_Last);
Container.Last := New_Last;
@ -2228,9 +2280,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- The tampering bits exist to prevent an item from being harmfully
-- manipulated while it is being visited. Query, Update, and Iterate
-- increment the busy count on entry, and decrement the count on
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
-- increment the busy count on entry, and decrement the count on exit.
-- Insert checks the count to determine whether it is being called while
-- the associated callback procedure is executing.
if Container.Busy > 0 then
raise Program_Error with
@ -2247,6 +2299,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Before <= Container.Last then
-- The new space is being inserted before some existing
-- elements, so we must slide the existing elements up to their
-- new home. We use the wider of Index_Type'Base and
@ -2288,6 +2341,7 @@ package body Ada.Containers.Indefinite_Vectors is
end loop;
if New_Capacity > Max_Length then
-- We have reached the limit of capacity, so no further expansion
-- will occur. (This is not a problem, as there is never a need to
-- have more capacity than the maximum container length.)
@ -2325,6 +2379,7 @@ package body Ada.Containers.Indefinite_Vectors is
Src.EA (Index_Type'First .. Before - 1);
if Before <= Container.Last then
-- The new items are being inserted before some existing elements,
-- so we must slide the existing elements up to their new home.
@ -2778,37 +2833,10 @@ package body Ada.Containers.Indefinite_Vectors is
-- Reference --
---------------
function Constant_Reference
(Container : Vector; Position : Cursor) -- SHOULD BE ALIASED
return Constant_Reference_Type is
begin
pragma Unreferenced (Container);
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
return
(Element => Position.Container.Elements.EA (Position.Index).all'Access);
end Constant_Reference;
function Constant_Reference
(Container : Vector; Position : Index_Type)
return Constant_Reference_Type is
begin
if (Position) > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
return (Element => Container.Elements.EA (Position).all'Access);
end Constant_Reference;
function Reference (Container : Vector; Position : Cursor)
return Reference_Type is
function Reference
(Container : Vector;
Position : Cursor) return Reference_Type
is
begin
pragma Unreferenced (Container);
@ -2825,8 +2853,10 @@ package body Ada.Containers.Indefinite_Vectors is
Position.Container.Elements.EA (Position.Index).all'Access);
end Reference;
function Reference (Container : Vector; Position : Index_Type)
return Reference_Type is
function Reference
(Container : Vector;
Position : Index_Type) return Reference_Type
is
begin
if Position > Container.Last then
raise Constraint_Error with "Index is out of range";
@ -2916,10 +2946,12 @@ package body Ada.Containers.Indefinite_Vectors is
-- container length.
if Capacity = 0 then
-- This is a request to trim back storage, to the minimum amount
-- possible given the current state of the container.
if N = 0 then
-- The container is empty, so in this unique case we can
-- deallocate the entire internal array. Note that an empty
-- container can never be busy, so there's no need to check the
@ -2927,6 +2959,7 @@ package body Ada.Containers.Indefinite_Vectors is
declare
X : Elements_Access := Container.Elements;
begin
-- First we remove the internal array from the container, to
-- handle the case when the deallocation raises an exception
@ -2942,6 +2975,7 @@ package body Ada.Containers.Indefinite_Vectors is
end;
elsif N < Container.Elements.EA'Length then
-- The container is not empty, and the current length is less than
-- the current capacity, so there's storage available to trim. In
-- this case, we allocate a new internal array having a length
@ -2994,6 +3028,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- any possibility of overflow.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then
-- determine whether it lies in the range of the index (sub)type.
@ -3022,6 +3057,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
elsif Index_Type'First <= 0 then
-- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of Capacity.
@ -3060,6 +3096,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- this is a request for expansion or contraction of storage.
if Container.Elements = null then
-- The container is empty (it doesn't even have an internal array),
-- so this represents a request to allocate storage having the given
-- capacity.
@ -3069,17 +3106,19 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
if Capacity <= N then
-- This is a request to trim back storage, but only to the limit of
-- what's already in the container. (Reserve_Capacity never deletes
-- active elements, it only reclaims excess storage.)
if N < Container.Elements.EA'Length then
-- The container is not empty (because the requested capacity is
-- positive, and less than or equal to the container length), and
-- the current length is less than the current capacity, so
-- there's storage available to trim. In this case, we allocate a
-- new internal array having a length that exactly matches the
-- number of items in the container.
-- the current length is less than the current capacity, so there
-- is storage available to trim. In this case, we allocate a new
-- internal array having a length that exactly matches the number
-- of items in the container.
if Container.Busy > 0 then
raise Program_Error with
@ -3122,6 +3161,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- current capacity is.
if Capacity = Container.Elements.EA'Length then
-- The requested capacity matches the existing capacity, so there's
-- nothing to do here. We treat this case as a no-op, and simply
-- return without checking the busy bit.
@ -3441,6 +3481,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- create a Last index value greater than Index_Type'Last.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then
-- determine whether it lies in the range of the index (sub)type.
@ -3469,6 +3510,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
elsif Index_Type'First <= 0 then
-- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of Length.
@ -3529,6 +3571,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- create a Last index value greater than Index_Type'Last.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then
-- determine whether it lies in the range of the index (sub)type.
@ -3557,6 +3600,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
elsif Index_Type'First <= 0 then
-- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of Length.
@ -3603,6 +3647,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- initialized when the handler executes. So here we initialize our loop
-- variable earlier than we prefer, before entering the block, so there
-- is no ambiguity.
Last := Index_Type'First;
begin

13
gcc/ada/a-convec.adb
View File

@ -1022,9 +1022,9 @@ package body Ada.Containers.Vectors is
-- There are two constraints we need to satisfy. The first constraint is
-- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the current length and the insertion
-- count. Note that we cannot simply add these values, because of the
-- possibility of overflow.
-- we must check the sum of the current length and the insertion count.
-- Note: we cannot simply add these values, because of the possibility
-- of overflow.
if Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range";
@ -1130,7 +1130,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length);
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if;
@ -1690,9 +1689,9 @@ package body Ada.Containers.Vectors is
-- There are two constraints we need to satisfy. The first constraint is
-- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the current length and the insertion
-- count. Note that we cannot simply add these values, because of the
-- possibility of overflow.
-- we must check the sum of the current length and the insertion count.
-- Note: we cannot simply add these values, because of the possibility
-- of overflow.
if Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range";

21
gcc/ada/a-stwiun-shared.ads
View File

@ -410,10 +410,10 @@ private
type Shared_Wide_String (Max_Length : Natural) is limited record
Counter : System.Atomic_Counters.Atomic_Counter;
-- Reference counter.
-- Reference counter
Last : Natural := 0;
Data : Wide_String (1 .. Max_Length);
Last : Natural := 0;
Data : Wide_String (1 .. Max_Length);
-- Last is the index of last significant element of the Data. All
-- elements with larger indices are just an extra room.
end record;
@ -424,8 +424,7 @@ private
-- Increment reference counter.
procedure Unreference (Item : not null Shared_Wide_String_Access);
-- Decrement reference counter. Deallocate Item when reference counter is
-- zero.
-- Decrement reference counter. Deallocate Item when ref counter is zero
function Can_Be_Reused
(Item : Shared_Wide_String_Access;
@ -445,7 +444,7 @@ private
function To_Unbounded (S : Wide_String) return Unbounded_Wide_String
renames To_Unbounded_Wide_String;
-- This renames are here only to be used in the pragma Stream_Convert.
-- This renames are here only to be used in the pragma Stream_Convert
type Unbounded_Wide_String is new AF.Controlled with record
Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access;
@ -453,22 +452,25 @@ private
-- The Unbounded_Wide_String uses several techniques to increase speed of
-- the application:
-- - implicit sharing or copy-on-write. Unbounded_Wide_String contains
-- only the reference to the data which is shared between several
-- instances. The shared data is reallocated only when its value is
-- changed and the object mutation can't be used or it is inefficient to
-- use it;
-- - object mutation. Shared data object can be reused without memory
-- reallocation when all of the following requirements are meat:
-- - shared data object don't used anywhere longer;
-- - its size is sufficient to store new value;
-- - the gap after reuse is less then some threshold.
-- - memory preallocation. Most of used memory allocation algorithms
-- aligns allocated segment on the some boundary, thus some amount of
-- additional memory can be preallocated without any impact. Such
-- preallocated memory can used later by Append/Insert operations
-- without reallocation.
--
-- Reference counting uses GCC builtin atomic operations, which allows to
-- safely share internal data between Ada tasks. Nevertheless, this not
-- make objects of Unbounded_Wide_String thread-safe, so each instance
@ -485,7 +487,8 @@ private
overriding procedure Finalize (Object : in out Unbounded_Wide_String);
Null_Unbounded_Wide_String : constant Unbounded_Wide_String :=
(AF.Controlled with
Reference => Empty_Shared_Wide_String'Access);
(AF.Controlled with
Reference =>
Empty_Shared_Wide_String'Access);
end Ada.Strings.Wide_Unbounded;

18
gcc/ada/a-stzunb-shared.ads
View File

@ -419,10 +419,10 @@ private
type Shared_Wide_Wide_String (Max_Length : Natural) is limited record
Counter : System.Atomic_Counters.Atomic_Counter;
-- Reference counter.
-- Reference counter
Last : Natural := 0;
Data : Wide_Wide_String (1 .. Max_Length);
Last : Natural := 0;
Data : Wide_Wide_String (1 .. Max_Length);
-- Last is the index of last significant element of the Data. All
-- elements with larger indices are just an extra room.
end record;
@ -466,22 +466,25 @@ private
-- The Unbounded_Wide_Wide_String uses several techniques to increase speed
-- of the application:
-- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String
-- contains only the reference to the data which is shared between
-- several instances. The shared data is reallocated only when its value
-- is changed and the object mutation can't be used or it is inefficient
-- to use it;
-- - object mutation. Shared data object can be reused without memory
-- reallocation when all of the following requirements are meat:
-- - shared data object don't used anywhere longer;
-- - its size is sufficient to store new value;
-- - the gap after reuse is less then some threshold.
-- - memory preallocation. Most of used memory allocation algorithms
-- aligns allocated segment on the some boundary, thus some amount of
-- additional memory can be preallocated without any impact. Such
-- preallocated memory can used later by Append/Insert operations
-- without reallocation.
--
-- Reference counting uses GCC builtin atomic operations, which allows to
-- safely share internal data between Ada tasks. Nevertheless, this not
-- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance
@ -502,8 +505,9 @@ private
(Object : in out Unbounded_Wide_Wide_String);
Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String :=
(AF.Controlled with
Reference =>
Empty_Shared_Wide_Wide_String'Access);
(AF.Controlled with
Reference =>
Empty_Shared_Wide_Wide_String'
Access);
end Ada.Strings.Wide_Wide_Unbounded;

14
gcc/ada/a-suenco.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -92,10 +92,10 @@ package body Ada.Strings.UTF_Encoding.Conversions is
-- Output UTF-16 code
procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On
-- return Ptr is incremented. Raises exception if continuation
-- byte does not exist or is invalid.
-- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6
-- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr
-- is incremented. Raises exception if continuation byte does not exist
-- or is invalid.
----------------------
-- Get_Continuation --
@ -114,8 +114,8 @@ package body Ada.Strings.UTF_Encoding.Conversions is
Raise_Encoding_Error (Iptr - 1);
else
R := Shift_Left (R, 6) or
Unsigned_16 (C and 2#00_111111#);
R :=
Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#);
end if;
end if;
end Get_Continuation;

10
gcc/ada/a-suewst.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -66,10 +66,10 @@ package body Ada.Strings.UTF_Encoding.Wide_Strings is
R : Unsigned_16;
procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On
-- return Ptr is incremented. Raises exception if continuation
-- byte does not exist or is invalid.
-- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6
-- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr
-- is incremented. Raises exception if continuation byte does not exist
-- or is invalid.
----------------------
-- Get_Continuation --

10
gcc/ada/a-suezst.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -66,10 +66,10 @@ package body Ada.Strings.UTF_Encoding.Wide_Wide_Strings is
R : Unsigned_32;
procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On
-- return Ptr is incremented. Raises exception if continuation
-- byte does not exist or is invalid.
-- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6
-- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr
-- is incremented. Raises exception if continuation byte does not exist
-- or is invalid.
----------------------
-- Get_Continuation --

8
gcc/ada/s-osinte-aix.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -199,7 +199,8 @@ package System.OS_Interface is
type clockid_t is private;
CLOCK_REALTIME : constant clockid_t;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime
(clock_id : clockid_t;
@ -539,7 +540,8 @@ private
pragma Convention (C, timespec);
type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t := 0;
CLOCK_REALTIME : constant clockid_t := 9;
CLOCK_MONOTONIC : constant clockid_t := 10;
type pthread_attr_t is new System.Address;
pragma Convention (C, pthread_attr_t);

8
gcc/ada/s-osinte-darwin.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -185,7 +185,8 @@ package System.OS_Interface is
type clockid_t is private;
CLOCK_REALTIME : constant clockid_t;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime
(clock_id : clockid_t;
@ -516,7 +517,8 @@ private
pragma Convention (C, timespec);
type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t := 0;
CLOCK_REALTIME : constant clockid_t := 0;
CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME;
--
-- Darwin specific signal implementation

8
gcc/ada/s-osinte-freebsd.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -202,7 +202,8 @@ package System.OS_Interface is
type clockid_t is private;
CLOCK_REALTIME : constant clockid_t;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime
(clock_id : clockid_t;
@ -635,7 +636,8 @@ private
pragma Convention (C, timespec);
type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t := 0;
CLOCK_REALTIME : constant clockid_t := 0;
CLOCK_MONOTONIC : constant clockid_t := 4;
type pthread_t is new System.Address;
type pthread_attr_t is new System.Address;

8
gcc/ada/s-osinte-hpux.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -182,7 +182,8 @@ package System.OS_Interface is
type clockid_t is private;
CLOCK_REALTIME : constant clockid_t;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime
(clock_id : clockid_t;
@ -521,7 +522,8 @@ private
pragma Convention (C, timespec);
type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t := 1;
CLOCK_REALTIME : constant clockid_t := 1;
CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME;
type pthread_attr_t is new int;
type pthread_condattr_t is new int;

8
gcc/ada/s-osinte-lynxos.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -199,7 +199,8 @@ package System.OS_Interface is
type clockid_t is private;
CLOCK_REALTIME : constant clockid_t;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime
(clock_id : clockid_t;
@ -517,7 +518,8 @@ private
pragma Convention (C, timespec);
type clockid_t is new unsigned_char;
CLOCK_REALTIME : constant clockid_t := 0;
CLOCK_REALTIME : constant clockid_t := 1;
CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME;
type st_attr_t is record
stksize : int;

8
gcc/ada/s-osinte-solaris-posix.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -189,7 +189,8 @@ package System.OS_Interface is
type clockid_t is private;
CLOCK_REALTIME : constant clockid_t;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime
(clock_id : clockid_t;
@ -512,7 +513,8 @@ private
pragma Convention (C, timespec);
type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t := 0;
CLOCK_REALTIME : constant clockid_t := 3;
CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME;
type pthread_attr_t is record
pthread_attrp : System.Address;

2
gcc/ada/s-taprop-posix.adb
View File

@ -666,7 +666,7 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
Result := clock_gettime
(clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
(clock_id => CLOCK_MONOTONIC, tp => TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;

26
gcc/ada/sem_ch6.adb
View File

@ -268,6 +268,7 @@ package body Sem_Ch6 is
Loc : constant Source_Ptr := Sloc (N);
LocX : constant Source_Ptr := Sloc (Expression (N));
Def_Id : constant Entity_Id := Defining_Entity (Specification (N));
Expr : constant Node_Id := Expression (N);
New_Body : Node_Id;
New_Decl : Node_Id;
@ -315,31 +316,28 @@ package body Sem_Ch6 is
Set_Is_Inlined (Prev);
Analyze (N);
-- If this is not a completion, create both a declaration and a body,
-- so that the expression can be inlined whenever possible.
-- If this is not a completion, create both a declaration and a body, so
-- that the expression can be inlined whenever possible. The spec of the
-- new subprogram declaration is a copy of the original specification,
-- which is now part of the subprogram body.
else
New_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => Specification (N));
Specification => Copy_Separate_Tree (Specification (N)));
Rewrite (N, New_Decl);
Analyze (N);
Set_Is_Inlined (Defining_Entity (New_Decl));
-- Create new set of formals for specification in body.
Set_Specification (New_Body,
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))),
Parameter_Specifications =>
Copy_Parameter_List (Defining_Entity (New_Decl)),
Result_Definition =>
New_Copy_Tree (Result_Definition (Specification (New_Decl)))));
Insert_After (N, New_Body);
Analyze (New_Body);
end if;
-- If the return expression is a static constant, we suppress warning
-- messages on unused formals, which in most cases will be noise.
Set_Is_Trivial_Subprogram (Defining_Entity (New_Body),
Is_OK_Static_Expression (Expr));
end Analyze_Expression_Function;
----------------------------------------

4
gcc/ada/tree_io.ads
View File

@ -47,12 +47,14 @@ package Tree_IO is
Tree_Format_Error : exception;
-- Raised if a format error is detected in the input file
ASIS_Version_Number : constant := 26;
ASIS_Version_Number : constant := 27;
-- ASIS Version. This is used to check for consistency between the compiler
-- used to generate trees and an ASIS application that is reading the
-- trees. It must be incremented whenever a change is made to the tree
-- format that would result in the compiler being incompatible with an
-- older version of ASIS.
--
-- 27 2011-09-06 Changes in the tree structures for expression functions
procedure Tree_Read_Initialize (Desc : File_Descriptor);
-- Called to initialize reading of a tree file. This call must be made