Commit 0b5b2bbc by Arnaud Charlet

[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
parent 21f1e8ce
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> 2011-09-11 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/utils.c (maybe_unconstrained_array): In the reference * gcc-interface/utils.c (maybe_unconstrained_array): In the reference
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 ...@@ -546,11 +546,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
"attempt to tamper with cursors (container is busy)"; "attempt to tamper with cursors (container is busy)";
end if; end if;
-- Note that there's no way to decide a priori whether the -- Note that there's no way to decide a priori whether the target has
-- target has enough capacity for the union with source. -- enough capacity for the union with source. We cannot simply compare
-- We cannot simply compare the sum of the existing lengths -- the sum of the existing lengths to the capacity of the target,
-- to the capacity of the target, because equivalent items -- because equivalent items from source are not included in the union.
-- from source are not included in the union.
Iterate (Source); Iterate (Source);
end Set_Union; end Set_Union;
......
...@@ -582,52 +582,52 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -582,52 +582,52 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
-- The list container actually contains two lists: one for the "active" -- The list container actually contains two lists: one for the "active"
-- nodes that contain elements that have been inserted onto the list, -- nodes that contain elements that have been inserted onto the list,
-- and another for the "inactive" nodes for the free store. -- and another for the "inactive" nodes for the free store.
--
-- We desire that merely declaring an object should have only minimal -- We desire that merely declaring an object should have only minimal
-- cost; specially, we want to avoid having to initialize the free -- cost; specially, we want to avoid having to initialize the free
-- store (to fill in the links), especially if the capacity is large. -- 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 -- The head of the free list is indicated by Container.Free. If its
-- value is non-negative, then the free store has been initialized -- value is non-negative, then the free store has been initialized in
-- in the "normal" way: Container.Free points to the head of the list -- the "normal" way: Container.Free points to the head of the list of
-- of free (inactive) nodes, and the value 0 means the free list is -- free (inactive) nodes, and the value 0 means the free list is empty.
-- empty. Each node on the free list has been initialized to point -- Each node on the free list has been initialized to point to the next
-- to the next free node (via its Next component), and the value 0 -- free node (via its Next component), and the value 0 means that this
-- means that this is the last free node. -- is the last free node.
--
-- If Container.Free is negative, then the links on the free store -- If Container.Free is negative, then the links on the free store have
-- have not been initialized. In this case the link values are -- not been initialized. In this case the link values are implied: the
-- implied: the free store comprises the components of the node array -- free store comprises the components of the node array started with
-- started with the absolute value of Container.Free, and continuing -- the absolute value of Container.Free, and continuing until the end of
-- until the end of the array (Nodes'Last). -- the array (Nodes'Last).
--
-- If the list container is manipulated on one end only (for example -- If the list container is manipulated on one end only (for example if
-- if the container were being used as a stack), then there is no -- the container were being used as a stack), then there is no need to
-- need to initialize the free store, since the inactive nodes are -- initialize the free store, since the inactive nodes are physically
-- physically contiguous (in fact, they lie immediately beyond the -- contiguous (in fact, they lie immediately beyond the logical end
-- logical end being manipulated). The only time we need to actually -- being manipulated). The only time we need to actually initialize the
-- initialize the nodes in the free store is if the node that becomes -- nodes in the free store is if the node that becomes inactive is not
-- inactive is not at the end of the list. The free store would then -- at the end of the list. The free store would then be discontiguous
-- be discontiguous and so its nodes would need to be linked in the -- and so its nodes would need to be linked in the traditional way.
-- traditional way.
--
-- ??? -- ???
-- It might be possible to perform an optimization here. Suppose that -- It might be possible to perform an optimization here. Suppose that
-- the free store can be represented as having two parts: one -- the free store can be represented as having two parts: one comprising
-- comprising the non-contiguous inactive nodes linked together -- the non-contiguous inactive nodes linked together in the normal way,
-- in the normal way, and the other comprising the contiguous -- and the other comprising the contiguous inactive nodes (that are not
-- inactive nodes (that are not linked together, at the end of the -- linked together, at the end of the nodes array). This would allow us
-- nodes array). This would allow us to never have to initialize -- to never have to initialize the free store, except in a lazy way as
-- the free store, except in a lazy way as nodes become inactive. -- nodes become inactive.
-- When an element is deleted from the list container, its node -- When an element is deleted from the list container, its node becomes
-- becomes inactive, and so we set its Prev component to a negative -- inactive, and so we set its Prev component to a negative value, to
-- value, to indicate that it is now inactive. This provides a useful -- indicate that it is now inactive. This provides a useful way to
-- way to detect a dangling cursor reference. -- detect a dangling cursor reference.
N (X).Prev := -1; -- Node is deallocated (not on active list) N (X).Prev := -1; -- Node is deallocated (not on active list)
if Container.Free >= 0 then if Container.Free >= 0 then
-- The free store has previously been initialized. All we need to -- The free store has previously been initialized. All we need to
-- do here is link the newly-free'd node onto the free list. -- 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 ...@@ -635,11 +635,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Container.Free := X; Container.Free := X;
elsif X + 1 = abs Container.Free then elsif X + 1 = abs Container.Free then
-- The free store has not been initialized, and the node becoming -- The free store has not been initialized, and the node becoming
-- inactive immediately precedes the start of the free store. All -- 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. -- 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; Container.Free := Container.Free + 1;
else else
...@@ -650,11 +651,10 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -650,11 +651,10 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
-- node onto the head of the free store. -- node onto the head of the free store.
-- ??? -- ???
-- See the comments above for an optimization opportunity. If -- See the comments above for an optimization opportunity. If the
-- the next link for a node on the free store is negative, then -- next link for a node on the free store is negative, then this
-- this means the remaining nodes on the free store are -- means the remaining nodes on the free store are physically
-- physically contiguous, starting as the absolute value of -- contiguous, starting as the absolute value of that index value.
-- that index value.
Container.Free := abs Container.Free; Container.Free := abs Container.Free;
...@@ -689,7 +689,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -689,7 +689,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Node : Count_Type := Container.First; Node : Count_Type := Container.First;
begin 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 if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
return False; return False;
end if; end if;
...@@ -766,17 +766,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -766,17 +766,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
N : Node_Array renames Container.Nodes; N : Node_Array renames Container.Nodes;
procedure Partition (Pivot, Back : Count_Type); procedure Partition (Pivot, Back : Count_Type);
-- What does this do ???
procedure Sort (Front, Back : Count_Type); procedure Sort (Front, Back : Count_Type);
-- Internal procedure, what does it do??? rename it???
--------------- ---------------
-- Partition -- -- Partition --
--------------- ---------------
procedure Partition (Pivot, Back : Count_Type) is procedure Partition (Pivot, Back : Count_Type) is
Node : Count_Type := N (Pivot).Next; Node : Count_Type;
begin begin
Node := N (Pivot).Next;
while Node /= Back loop while Node /= Back loop
if N (Node).Element < N (Pivot).Element then if N (Node).Element < N (Pivot).Element then
declare declare
...@@ -2066,21 +2069,21 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is ...@@ -2066,21 +2069,21 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return False; return False;
end if; end if;
if Position.Node = L.First then -- eliminates earlier disjunct -- Eliminate earlier disjunct
if Position.Node = L.First then
return True; return True;
end if; end if;
-- If we get here, we know, per disjunctive syllogism (modus -- If we get here, we know (disjunctive syllogism) that this
-- tollendo ponens), that this predicate is true: -- predicate is true: N (Position.Node).Prev /= 0
-- N (Position.Node).Prev /= 0
if Position.Node = L.Last then -- eliminates earlier disjunct if Position.Node = L.Last then -- eliminates earlier disjunct
return True; return True;
end if; end if;
-- If we get here, we know, per disjunctive syllogism (modus -- If we get here, we know (disjunctive syllogism) that this
-- tollendo ponens), that this predicate is true: -- predicate is true: N (Position.Node).Next /= 0
-- N (Position.Node).Next /= 0
if N (N (Position.Node).Next).Prev /= Position.Node then if N (N (Position.Node).Next).Prev /= Position.Node then
return False; return False;
......
...@@ -1890,21 +1890,23 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1890,21 +1890,23 @@ package body Ada.Containers.Doubly_Linked_Lists is
return False; return False;
end if; end if;
if Position.Node = L.First then -- eliminates earlier disjunct -- Eliminate earlier disjunct
if Position.Node = L.First then
return True; return True;
end if; end if;
-- If we get here, we know, per disjunctive syllogism (modus -- If we get here, we know (disjunctive syllogism) that this
-- tollendo ponens), that this predicate is true: -- predicate is true: Position.Node.Prev /= null
-- Position.Node.Prev /= null
-- Eliminate earlier disjunct
if Position.Node = L.Last then -- eliminates earlier disjunct if Position.Node = L.Last then
return True; return True;
end if; end if;
-- If we get here, we know, per disjunctive syllogism (modus -- If we get here, we know (disjunctive syllogism) that this
-- tollendo ponens), that this predicate is true: -- predicate is true: Position.Node.Next /= null
-- Position.Node.Next /= null
if Position.Node.Next.Prev /= Position.Node then if Position.Node.Next.Prev /= Position.Node then
return False; return False;
......
...@@ -1394,8 +1394,8 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1394,8 +1394,8 @@ package body Ada.Containers.Bounded_Vectors is
-- There are two constraints we need to satisfy. The first constraint 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 -- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the current length and the insertion -- we must check the sum of the current length and the insertion count.
-- count. Note that we cannot simply add these values, because of the -- Note that we cannot simply add these values, because of the
-- possibility of overflow. -- possibility of overflow.
if Old_Length > Count_Type'Last - Count then if Old_Length > Count_Type'Last - Count then
......
...@@ -1022,9 +1022,9 @@ package body Ada.Containers.Vectors is ...@@ -1022,9 +1022,9 @@ package body Ada.Containers.Vectors is
-- There are two constraints we need to satisfy. The first constraint 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 -- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the current length and the insertion -- we must check the sum of the current length and the insertion count.
-- count. Note that we cannot simply add these values, because of the -- Note: we cannot simply add these values, because of the possibility
-- possibility of overflow. -- of overflow.
if Old_Length > Count_Type'Last - Count then if Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
...@@ -1130,7 +1130,6 @@ package body Ada.Containers.Vectors is ...@@ -1130,7 +1130,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length); New_Last := No_Index + Index_Type'Base (New_Length);
else else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if; end if;
...@@ -1690,9 +1689,9 @@ package body Ada.Containers.Vectors is ...@@ -1690,9 +1689,9 @@ package body Ada.Containers.Vectors is
-- There are two constraints we need to satisfy. The first constraint 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 -- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the current length and the insertion -- we must check the sum of the current length and the insertion count.
-- count. Note that we cannot simply add these values, because of the -- Note: we cannot simply add these values, because of the possibility
-- possibility of overflow. -- of overflow.
if Old_Length > Count_Type'Last - Count then if Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
......
...@@ -410,10 +410,10 @@ private ...@@ -410,10 +410,10 @@ private
type Shared_Wide_String (Max_Length : Natural) is limited record type Shared_Wide_String (Max_Length : Natural) is limited record
Counter : System.Atomic_Counters.Atomic_Counter; Counter : System.Atomic_Counters.Atomic_Counter;
-- Reference counter. -- Reference counter
Last : Natural := 0; Last : Natural := 0;
Data : Wide_String (1 .. Max_Length); Data : Wide_String (1 .. Max_Length);
-- Last is the index of last significant element of the Data. All -- Last is the index of last significant element of the Data. All
-- elements with larger indices are just an extra room. -- elements with larger indices are just an extra room.
end record; end record;
...@@ -424,8 +424,7 @@ private ...@@ -424,8 +424,7 @@ private
-- Increment reference counter. -- Increment reference counter.
procedure Unreference (Item : not null Shared_Wide_String_Access); procedure Unreference (Item : not null Shared_Wide_String_Access);
-- Decrement reference counter. Deallocate Item when reference counter is -- Decrement reference counter. Deallocate Item when ref counter is zero
-- zero.
function Can_Be_Reused function Can_Be_Reused
(Item : Shared_Wide_String_Access; (Item : Shared_Wide_String_Access;
...@@ -445,7 +444,7 @@ private ...@@ -445,7 +444,7 @@ private
function To_Unbounded (S : Wide_String) return Unbounded_Wide_String function To_Unbounded (S : Wide_String) return Unbounded_Wide_String
renames To_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 type Unbounded_Wide_String is new AF.Controlled with record
Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access; Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access;
...@@ -453,22 +452,25 @@ private ...@@ -453,22 +452,25 @@ private
-- The Unbounded_Wide_String uses several techniques to increase speed of -- The Unbounded_Wide_String uses several techniques to increase speed of
-- the application: -- the application:
-- - implicit sharing or copy-on-write. Unbounded_Wide_String contains -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains
-- only the reference to the data which is shared between several -- only the reference to the data which is shared between several
-- instances. The shared data is reallocated only when its value is -- 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 -- changed and the object mutation can't be used or it is inefficient to
-- use it; -- use it;
-- - object mutation. Shared data object can be reused without memory -- - object mutation. Shared data object can be reused without memory
-- reallocation when all of the following requirements are meat: -- reallocation when all of the following requirements are meat:
-- - shared data object don't used anywhere longer; -- - shared data object don't used anywhere longer;
-- - its size is sufficient to store new value; -- - its size is sufficient to store new value;
-- - the gap after reuse is less then some threshold. -- - the gap after reuse is less then some threshold.
-- - memory preallocation. Most of used memory allocation algorithms -- - memory preallocation. Most of used memory allocation algorithms
-- aligns allocated segment on the some boundary, thus some amount of -- aligns allocated segment on the some boundary, thus some amount of
-- additional memory can be preallocated without any impact. Such -- additional memory can be preallocated without any impact. Such
-- preallocated memory can used later by Append/Insert operations -- preallocated memory can used later by Append/Insert operations
-- without reallocation. -- without reallocation.
--
-- Reference counting uses GCC builtin atomic operations, which allows to -- Reference counting uses GCC builtin atomic operations, which allows to
-- safely share internal data between Ada tasks. Nevertheless, this not -- safely share internal data between Ada tasks. Nevertheless, this not
-- make objects of Unbounded_Wide_String thread-safe, so each instance -- make objects of Unbounded_Wide_String thread-safe, so each instance
...@@ -485,7 +487,8 @@ private ...@@ -485,7 +487,8 @@ private
overriding procedure Finalize (Object : in out Unbounded_Wide_String); overriding procedure Finalize (Object : in out Unbounded_Wide_String);
Null_Unbounded_Wide_String : constant Unbounded_Wide_String := Null_Unbounded_Wide_String : constant Unbounded_Wide_String :=
(AF.Controlled with (AF.Controlled with
Reference => Empty_Shared_Wide_String'Access); Reference =>
Empty_Shared_Wide_String'Access);
end Ada.Strings.Wide_Unbounded; end Ada.Strings.Wide_Unbounded;
...@@ -419,10 +419,10 @@ private ...@@ -419,10 +419,10 @@ private
type Shared_Wide_Wide_String (Max_Length : Natural) is limited record type Shared_Wide_Wide_String (Max_Length : Natural) is limited record
Counter : System.Atomic_Counters.Atomic_Counter; Counter : System.Atomic_Counters.Atomic_Counter;
-- Reference counter. -- Reference counter
Last : Natural := 0; Last : Natural := 0;
Data : Wide_Wide_String (1 .. Max_Length); Data : Wide_Wide_String (1 .. Max_Length);
-- Last is the index of last significant element of the Data. All -- Last is the index of last significant element of the Data. All
-- elements with larger indices are just an extra room. -- elements with larger indices are just an extra room.
end record; end record;
...@@ -466,22 +466,25 @@ private ...@@ -466,22 +466,25 @@ private
-- The Unbounded_Wide_Wide_String uses several techniques to increase speed -- The Unbounded_Wide_Wide_String uses several techniques to increase speed
-- of the application: -- of the application:
-- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String
-- contains only the reference to the data which is shared between -- contains only the reference to the data which is shared between
-- several instances. The shared data is reallocated only when its value -- 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 -- is changed and the object mutation can't be used or it is inefficient
-- to use it; -- to use it;
-- - object mutation. Shared data object can be reused without memory -- - object mutation. Shared data object can be reused without memory
-- reallocation when all of the following requirements are meat: -- reallocation when all of the following requirements are meat:
-- - shared data object don't used anywhere longer; -- - shared data object don't used anywhere longer;
-- - its size is sufficient to store new value; -- - its size is sufficient to store new value;
-- - the gap after reuse is less then some threshold. -- - the gap after reuse is less then some threshold.
-- - memory preallocation. Most of used memory allocation algorithms -- - memory preallocation. Most of used memory allocation algorithms
-- aligns allocated segment on the some boundary, thus some amount of -- aligns allocated segment on the some boundary, thus some amount of
-- additional memory can be preallocated without any impact. Such -- additional memory can be preallocated without any impact. Such
-- preallocated memory can used later by Append/Insert operations -- preallocated memory can used later by Append/Insert operations
-- without reallocation. -- without reallocation.
--
-- Reference counting uses GCC builtin atomic operations, which allows to -- Reference counting uses GCC builtin atomic operations, which allows to
-- safely share internal data between Ada tasks. Nevertheless, this not -- safely share internal data between Ada tasks. Nevertheless, this not
-- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance -- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance
...@@ -502,8 +505,9 @@ private ...@@ -502,8 +505,9 @@ private
(Object : in out Unbounded_Wide_Wide_String); (Object : in out Unbounded_Wide_Wide_String);
Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String :=
(AF.Controlled with (AF.Controlled with
Reference => Reference =>
Empty_Shared_Wide_Wide_String'Access); Empty_Shared_Wide_Wide_String'
Access);
end Ada.Strings.Wide_Wide_Unbounded; end Ada.Strings.Wide_Wide_Unbounded;
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 ...@@ -92,10 +92,10 @@ package body Ada.Strings.UTF_Encoding.Conversions is
-- Output UTF-16 code -- Output UTF-16 code
procedure Get_Continuation; procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr
-- return Ptr is incremented. Raises exception if continuation -- is incremented. Raises exception if continuation byte does not exist
-- byte does not exist or is invalid. -- or is invalid.
---------------------- ----------------------
-- Get_Continuation -- -- Get_Continuation --
...@@ -114,8 +114,8 @@ package body Ada.Strings.UTF_Encoding.Conversions is ...@@ -114,8 +114,8 @@ package body Ada.Strings.UTF_Encoding.Conversions is
Raise_Encoding_Error (Iptr - 1); Raise_Encoding_Error (Iptr - 1);
else else
R := Shift_Left (R, 6) or R :=
Unsigned_16 (C and 2#00_111111#); Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#);
end if; end if;
end if; end if;
end Get_Continuation; end Get_Continuation;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 ...@@ -66,10 +66,10 @@ package body Ada.Strings.UTF_Encoding.Wide_Strings is
R : Unsigned_16; R : Unsigned_16;
procedure Get_Continuation; procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr
-- return Ptr is incremented. Raises exception if continuation -- is incremented. Raises exception if continuation byte does not exist
-- byte does not exist or is invalid. -- or is invalid.
---------------------- ----------------------
-- Get_Continuation -- -- Get_Continuation --
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 ...@@ -66,10 +66,10 @@ package body Ada.Strings.UTF_Encoding.Wide_Wide_Strings is
R : Unsigned_32; R : Unsigned_32;
procedure Get_Continuation; procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr
-- return Ptr is incremented. Raises exception if continuation -- is incremented. Raises exception if continuation byte does not exist
-- byte does not exist or is invalid. -- or is invalid.
---------------------- ----------------------
-- Get_Continuation -- -- Get_Continuation --
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -199,7 +199,8 @@ package System.OS_Interface is ...@@ -199,7 +199,8 @@ package System.OS_Interface is
type clockid_t is private; type clockid_t is private;
CLOCK_REALTIME : constant clockid_t; CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -539,7 +540,8 @@ private ...@@ -539,7 +540,8 @@ private
pragma Convention (C, timespec); pragma Convention (C, timespec);
type clockid_t is new int; 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; type pthread_attr_t is new System.Address;
pragma Convention (C, pthread_attr_t); pragma Convention (C, pthread_attr_t);
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -185,7 +185,8 @@ package System.OS_Interface is ...@@ -185,7 +185,8 @@ package System.OS_Interface is
type clockid_t is private; type clockid_t is private;
CLOCK_REALTIME : constant clockid_t; CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -516,7 +517,8 @@ private ...@@ -516,7 +517,8 @@ private
pragma Convention (C, timespec); pragma Convention (C, timespec);
type clockid_t is new int; 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 -- Darwin specific signal implementation
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -202,7 +202,8 @@ package System.OS_Interface is ...@@ -202,7 +202,8 @@ package System.OS_Interface is
type clockid_t is private; type clockid_t is private;
CLOCK_REALTIME : constant clockid_t; CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -635,7 +636,8 @@ private ...@@ -635,7 +636,8 @@ private
pragma Convention (C, timespec); pragma Convention (C, timespec);
type clockid_t is new int; 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_t is new System.Address;
type pthread_attr_t is new System.Address; type pthread_attr_t is new System.Address;
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -182,7 +182,8 @@ package System.OS_Interface is ...@@ -182,7 +182,8 @@ package System.OS_Interface is
type clockid_t is private; type clockid_t is private;
CLOCK_REALTIME : constant clockid_t; CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -521,7 +522,8 @@ private ...@@ -521,7 +522,8 @@ private
pragma Convention (C, timespec); pragma Convention (C, timespec);
type clockid_t is new int; 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_attr_t is new int;
type pthread_condattr_t is new int; type pthread_condattr_t is new int;
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -199,7 +199,8 @@ package System.OS_Interface is ...@@ -199,7 +199,8 @@ package System.OS_Interface is
type clockid_t is private; type clockid_t is private;
CLOCK_REALTIME : constant clockid_t; CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -517,7 +518,8 @@ private ...@@ -517,7 +518,8 @@ private
pragma Convention (C, timespec); pragma Convention (C, timespec);
type clockid_t is new unsigned_char; 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 type st_attr_t is record
stksize : int; stksize : int;
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -189,7 +189,8 @@ package System.OS_Interface is ...@@ -189,7 +189,8 @@ package System.OS_Interface is
type clockid_t is private; type clockid_t is private;
CLOCK_REALTIME : constant clockid_t; CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -512,7 +513,8 @@ private ...@@ -512,7 +513,8 @@ private
pragma Convention (C, timespec); pragma Convention (C, timespec);
type clockid_t is new int; 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 type pthread_attr_t is record
pthread_attrp : System.Address; pthread_attrp : System.Address;
......
...@@ -666,7 +666,7 @@ package body System.Task_Primitives.Operations is ...@@ -666,7 +666,7 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int; Result : Interfaces.C.int;
begin begin
Result := clock_gettime Result := clock_gettime
(clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); (clock_id => CLOCK_MONOTONIC, tp => TS'Unchecked_Access);
pragma Assert (Result = 0); pragma Assert (Result = 0);
return To_Duration (TS); return To_Duration (TS);
end Monotonic_Clock; end Monotonic_Clock;
......
...@@ -268,6 +268,7 @@ package body Sem_Ch6 is ...@@ -268,6 +268,7 @@ package body Sem_Ch6 is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
LocX : constant Source_Ptr := Sloc (Expression (N)); LocX : constant Source_Ptr := Sloc (Expression (N));
Def_Id : constant Entity_Id := Defining_Entity (Specification (N)); Def_Id : constant Entity_Id := Defining_Entity (Specification (N));
Expr : constant Node_Id := Expression (N);
New_Body : Node_Id; New_Body : Node_Id;
New_Decl : Node_Id; New_Decl : Node_Id;
...@@ -315,31 +316,28 @@ package body Sem_Ch6 is ...@@ -315,31 +316,28 @@ package body Sem_Ch6 is
Set_Is_Inlined (Prev); Set_Is_Inlined (Prev);
Analyze (N); Analyze (N);
-- If this is not a completion, create both a declaration and a body, -- If this is not a completion, create both a declaration and a body, so
-- so that the expression can be inlined whenever possible. -- 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 else
New_Decl := New_Decl :=
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
Specification => Specification (N)); Specification => Copy_Separate_Tree (Specification (N)));
Rewrite (N, New_Decl); Rewrite (N, New_Decl);
Analyze (N); Analyze (N);
Set_Is_Inlined (Defining_Entity (New_Decl)); 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); Insert_After (N, New_Body);
Analyze (New_Body); Analyze (New_Body);
end if; 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; end Analyze_Expression_Function;
---------------------------------------- ----------------------------------------
......
...@@ -47,12 +47,14 @@ package Tree_IO is ...@@ -47,12 +47,14 @@ package Tree_IO is
Tree_Format_Error : exception; Tree_Format_Error : exception;
-- Raised if a format error is detected in the input file -- 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 -- ASIS Version. This is used to check for consistency between the compiler
-- used to generate trees and an ASIS application that is reading the -- 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 -- trees. It must be incremented whenever a change is made to the tree
-- format that would result in the compiler being incompatible with an -- format that would result in the compiler being incompatible with an
-- older version of ASIS. -- older version of ASIS.
--
-- 27 2011-09-06 Changes in the tree structures for expression functions
procedure Tree_Read_Initialize (Desc : File_Descriptor); procedure Tree_Read_Initialize (Desc : File_Descriptor);
-- Called to initialize reading of a tree file. This call must be made -- Called to initialize reading of a tree file. This call must be made
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment