+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
-- --
-- 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- --
"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;
-- 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.
-
- -- 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.
+ -- 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.
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.
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
-- 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;
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;
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
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;
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
+
+ -- Eliminate earlier disjunct
- if Position.Node = L.Last then -- eliminates 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;
-- 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
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 --
--------------
-- 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
-- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+
-- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then
+
-- We know that No_Index (the same as Index_Type'First - 1) is
-- less than 0, so it is safe to compute the following sum without
-- fear of overflow.
Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then
+
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
end if;
elsif Index_Type'First <= 0 then
+
-- We know that No_Index (the same as Index_Type'First - 1) is less
-- than 0, so it is safe to compute the following sum without fear of
-- overflow.
J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then
+
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the maximum
-- number of items that are allowed.
-- 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
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.
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
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
-
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
end 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.)
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.
-- 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
-- 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
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.
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
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
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);
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);
-- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then
+
-- We know that No_Index (the same as Index_Type'First - 1) is
-- less than 0, so it is safe to compute the following sum without
-- fear of overflow.
Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then
+
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed.
end if;
elsif Index_Type'First <= 0 then
+
-- We know that No_Index (the same as Index_Type'First - 1) is less
-- than 0, so it is safe to compute the following sum without fear of
-- overflow.
J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then
+
-- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the maximum
-- number of items that are allowed.
-- 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;
-- 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
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
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.)
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.
-- 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);
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";
-- 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
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
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
-- 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.
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.
-- 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.
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
-- 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.
-- 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.
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.
-- 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.
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.
-- 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
-- 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";
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;
-- 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";
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;
-- 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;
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;
-- 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
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;
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;
-- 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
(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;
-- --
-- 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- --
-- 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 --
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;
-- --
-- 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- --
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 --
-- --
-- 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- --
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 --
-- 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- --
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;
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);
-- 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- --
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;
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
-- 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- --
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;
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;
-- 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- --
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;
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;
-- 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- --
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;
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;
-- 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- --
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;
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;
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;
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;
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;
----------------------------------------
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
OSDN Git Service
