mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-12-21 01:55:15 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-11-20  Thomas Quinot  <quinot@adacore.com>

	* sem_ch13.adb, freeze.adb: Minor reformatting.
	* gnat_rm.texi: Minor editing.

2014-11-20  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Analyze_Pragma): Minor reformatting.
	(Process_Suppress_Unsuppress): Ignore suppress Elaboration_Check
	in SPARK.

2014-11-20  Bob Duff  <duff@adacore.com>

	* gnat_rm.texi: Correction to documentation of
	'Unrestricted_Access in case of access to unconstrained array.
	* a-cofove.adb (Capacity): Fix bug -- was always
	returning Capacity_Range'Last.
	(Is_Sorted): Fix bug -- was always returning True, because
	Container.Last = Last. That test isn't even needed, because the
	loop will go around zero times in that case, so deleted that
	test rather than fixing it.
	(Reverse_Elements): Make sure to use the correct array bounds.

2014-11-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Analyze_Associations): In GNATProve mode, build
	wrappers for functions and operators that are actuals only if
	expander is enabled. Wrappers play no role within a generic unit.

2014-11-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_util.adb (Policy_In_Effect): Use the
	configuration level assertion flag.

From-SVN: r217880
This commit is contained in:
Arnaud Charlet 2014-11-20 16:54:31 +01:00
parent d7d99211f9
commit bcdb6b04a7
8 changed files with 106 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
gcc/ada/ChangeLog
View File

@ -1,3 +1,37 @@
2014-11-20 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb, freeze.adb: Minor reformatting.
* gnat_rm.texi: Minor editing.
2014-11-20 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (Analyze_Pragma): Minor reformatting.
(Process_Suppress_Unsuppress): Ignore suppress Elaboration_Check
in SPARK.
2014-11-20 Bob Duff <duff@adacore.com>
* gnat_rm.texi: Correction to documentation of
'Unrestricted_Access in case of access to unconstrained array.
* a-cofove.adb (Capacity): Fix bug -- was always
returning Capacity_Range'Last.
(Is_Sorted): Fix bug -- was always returning True, because
Container.Last = Last. That test isn't even needed, because the
loop will go around zero times in that case, so deleted that
test rather than fixing it.
(Reverse_Elements): Make sure to use the correct array bounds.
2014-11-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Analyze_Associations): In GNATProve mode, build
wrappers for functions and operators that are actuals only if
expander is enabled. Wrappers play no role within a generic unit.
2014-11-20 Hristian Kirtchev <kirtchev@adacore.com>
* sem_util.adb (Policy_In_Effect): Use the
configuration level assertion flag.
2014-11-20 Arnaud Charlet <charlet@adacore.com>
* s-parame-ae653.ads: Update comments.

71
gcc/ada/a-cofove.adb
View File

@ -150,7 +150,9 @@ is
function Capacity (Container : Vector) return Capacity_Range is
begin
return Elemsc (Container)'Length;
return (if Container.Elements_Ptr = null
then Container.Elements'Length
else Container.Elements_Ptr.all'Length);
end Capacity;
-----------
@ -160,8 +162,10 @@ is
procedure Clear (Container : in out Vector) is
begin
Container.Last := No_Index;
-- Free element, note that this is OK if Elements_Ptr is null
Free (Container.Elements_Ptr);
-- It's OK if Container.Elements_Ptr is null
end Clear;
--------------
@ -211,8 +215,7 @@ is
Current : Index_Type) return Vector
is
begin
return Result : Vector
(Count_Type (Container.Last - Current + 1))
return Result : Vector (Count_Type (Container.Last - Current + 1))
do
for X in Current .. Container.Last loop
Append (Result, Element (Container, X));
@ -268,16 +271,16 @@ is
function Elems (Container : in out Vector) return Maximal_Array_Ptr is
begin
return (if Container.Elements_Ptr = null
then Container.Elements'Unrestricted_Access
else Container.Elements_Ptr.all'Unrestricted_Access);
then Container.Elements'Unrestricted_Access
else Container.Elements_Ptr.all'Unrestricted_Access);
end Elems;
function Elemsc
(Container : Vector) return Maximal_Array_Ptr_Const is
begin
return (if Container.Elements_Ptr = null
then Container.Elements'Unrestricted_Access
else Container.Elements_Ptr.all'Unrestricted_Access);
then Container.Elements'Unrestricted_Access
else Container.Elements_Ptr.all'Unrestricted_Access);
end Elemsc;
----------------
@ -313,9 +316,9 @@ is
begin
if Is_Empty (Container) then
raise Constraint_Error with "Container is empty";
else
return Get_Element (Container, 1);
end if;
return Get_Element (Container, 1);
end First_Element;
-----------------
@ -357,24 +360,15 @@ is
---------------
function Is_Sorted (Container : Vector) return Boolean is
Last : constant Index_Type := Last_Index (Container);
L : constant Capacity_Range := Length (Container);
begin
if Container.Last <= Last then
return True;
end if;
declare
L : constant Capacity_Range := Length (Container);
begin
for J in 1 .. L - 1 loop
if Get_Element (Container, J + 1) <
Get_Element (Container, J)
then
return False;
end if;
end loop;
end;
for J in 1 .. L - 1 loop
if Get_Element (Container, J + 1) <
Get_Element (Container, J)
then
return False;
end if;
end loop;
return True;
end Is_Sorted;
@ -396,9 +390,9 @@ is
begin
if Container.Last <= Index_Type'First then
return;
else
Sort (Elems (Container) (1 .. Len));
end if;
Sort (Elems (Container) (1 .. Len));
end Sort;
end Generic_Sorting;
@ -442,9 +436,9 @@ is
begin
if Is_Empty (Container) then
raise Constraint_Error with "Container is empty";
else
return Get_Element (Container, Length (Container));
end if;
return Get_Element (Container, Length (Container));
end Last_Element;
----------------
@ -464,7 +458,6 @@ is
L : constant Int := Int (Last_Index (Container));
F : constant Int := Int (Index_Type'First);
N : constant Int'Base := L - F + 1;
begin
return Capacity_Range (N);
end Length;
@ -486,7 +479,6 @@ is
declare
II : constant Int'Base := Int (Index) - Int (No_Index);
I : constant Capacity_Range := Capacity_Range (II);
begin
Elems (Container) (I) := New_Item;
end;
@ -509,8 +501,8 @@ is
if Capacity > Formal_Vectors.Capacity (Container) then
declare
New_Elements : constant Elements_Array_Ptr :=
new Elements_Array (1 .. Capacity);
L : constant Capacity_Range := Length (Container);
new Elements_Array (1 .. Capacity);
L : constant Capacity_Range := Length (Container);
begin
New_Elements (1 .. L) := Elemsc (Container) (1 .. L);
Free (Container.Elements_Ptr);
@ -532,7 +524,8 @@ is
declare
I, J : Capacity_Range;
E : Elements_Array renames Elems (Container).all;
E : Elements_Array renames
Elems (Container) (1 .. Length (Container));
begin
I := 1;
@ -640,8 +633,10 @@ is
Last := Index_Type (Last_As_Int);
return (Capacity => Length, Last => Last, Elements_Ptr => <>,
Elements => (others => New_Item));
return (Capacity => Length,
Last => Last,
Elements_Ptr => <>,
Elements => (others => New_Item));
end;
end To_Vector;

7
gcc/ada/freeze.adb
View File

@ -7695,9 +7695,8 @@ package body Freeze is
procedure Set_SSO_From_Default (T : Entity_Id) is
begin
-- Set default SSO for an array or record base type, except in the case
-- of a type extension (which always inherits the SSO of its parent
-- type).
-- Set default SSO for an array or record base type, except in case of
-- a type extension (which always inherits the SSO of its parent type).
if Is_Base_Type (T)
and then (Is_Array_Type (T)
@ -7705,7 +7704,7 @@ package body Freeze is
and then not (Is_Tagged_Type (T)
and then Is_Derived_Type (T))))
then
if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
or else
((not Bytes_Big_Endian) and then SSO_Set_High_By_Default (T)))

22
gcc/ada/gnat_rm.texi
View File

@ -9994,17 +9994,17 @@ called after P2 returns, it would be an erroneous use of a dangling
pointer.
For objects, it is possible to use @code{Unrestricted_Access} for any
type, but care must be exercised if it is used to create pointers to
unconstrained array objects. In this case, the resulting pointer has
the same scope as the context of the attribute, and may not be
returned to some enclosing scope. For instance, a function cannot use
@code{Unrestricted_Access} to create a pointer to unconstrained and
then return that value to the caller. In addition, it is only valid
to create pointers to unconstrained arrays using this attribute if the
pointer has the normal default ``fat'' representation where a pointer
has two components, one points to the array and one points to the
bounds. If a size clause is used to force ``thin'' representation for
a pointer to unconstrained where there is only space for a single
type. However, if the result is of an access-to-unconstrained array
subtype, then the resulting pointer has the same scope as the context
of the attribute, and must not be returned to some enclosing scope.
For instance, if a function uses @code{Unrestricted_Access} to create
an access-to-unconstrained-array and returns that value to the caller,
the result will involve dangling pointers. In addition, it is only
valid to create pointers to unconstrained arrays using this attribute
if the pointer has the normal default ``fat'' representation where a
pointer has two components, one points to the array and one points to
the bounds. If a size clause is used to force ``thin'' representation
for a pointer to unconstrained where there is only space for a single
pointer, then the resulting pointer is not usable.
In the simple case where a direct use of Unrestricted_Access attempts

9
gcc/ada/sem_ch12.adb
View File

@ -1087,7 +1087,8 @@ package body Sem_Ch12 is
else
Parm_Type :=
Make_Identifier (Loc, Chars (Etype (Etype (Form_F))));
Make_Identifier (Loc,
Chars => Chars (First_Subtype (Etype (Form_F))));
end if;
-- If actual is present, use the type of its own formal
@ -1805,9 +1806,10 @@ package body Sem_Ch12 is
E_Function
then
-- If actual is an entity (function or operator),
-- build wrapper for it.
-- and expander is active, build wrapper for it.
-- Note that wrappers play no role within a generic.
if Present (Match) then
if Present (Match) and then Expander_Active then
if Nkind (Match) = N_Operator_Symbol then
-- If the name is a default, find its visible
@ -1835,6 +1837,7 @@ package body Sem_Ch12 is
elsif Box_Present (Formal)
and then Nkind (Defining_Entity (Analyzed_Formal)) =
N_Defining_Operator_Symbol
and then Expander_Active
then
Append_To (Assoc,
Build_Operator_Wrapper

11
gcc/ada/sem_ch13.adb
View File

@ -10971,10 +10971,8 @@ package body Sem_Ch13 is
-- in a flag of the base type!
if (Is_Record_Type (Typ) or else Is_Array_Type (Typ))
and then
Typ = Bas_Typ
and then Typ = Bas_Typ
then
-- For a type extension, always inherit from parent; otherwise
-- inherit if no default applies. Note: we do not check for
-- an explicit rep item on the parent type when inheriting,
@ -10983,10 +10981,9 @@ package body Sem_Ch13 is
if not Has_Rep_Item (First_Subtype (Typ),
Name_Scalar_Storage_Order, False)
and then (Is_Tagged_Type (Bas_Typ)
or else
not (SSO_Set_Low_By_Default (Bas_Typ)
or else
SSO_Set_High_By_Default (Bas_Typ)))
or else not (SSO_Set_Low_By_Default (Bas_Typ)
or else
SSO_Set_High_By_Default (Bas_Typ)))
then
Set_Reverse_Storage_Order (Bas_Typ,
Reverse_Storage_Order

15
gcc/ada/sem_prag.adb
View File

@ -2730,7 +2730,7 @@ package body Sem_Prag is
procedure Check_Ada_83_Warning;
-- Issues a warning message for the current pragma if operating in Ada
-- 83 mode (used for language pragmas that are not a standard part of
-- Ada 83). This procedure does not raise Error_Pragma. Also notes use
-- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
-- of 95 pragma.
procedure Check_Arg_Count (Required : Nat);
@ -9046,6 +9046,15 @@ package body Sem_Prag is
("argument of pragma% is not valid check name", Arg1);
end if;
-- Warn that suppress of Elaboration_Check has no effect in SPARK
if C = Elaboration_Check and then SPARK_Mode = On then
Error_Pragma_Arg
("Suppress of Elaboration_Check ignored in SPARK??", Arg1);
end if;
-- One-argument case
if Arg_Count = 1 then
-- Make an entry in the local scope suppress table. This is the
@ -20282,7 +20291,7 @@ package body Sem_Prag is
-- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
when Pragma_Suppress =>
Process_Suppress_Unsuppress (True);
Process_Suppress_Unsuppress (Suppress_Case => True);
------------------
-- Suppress_All --
@ -21120,7 +21129,7 @@ package body Sem_Prag is
when Pragma_Unsuppress =>
Ada_2005_Pragma;
Process_Suppress_Unsuppress (False);
Process_Suppress_Unsuppress (Suppress_Case => False);
----------------------------
-- Unevaluated_Use_Of_Old --

5
gcc/ada/sem_util.adb
View File

@ -15726,10 +15726,11 @@ package body Sem_Util is
end if;
-- The context lacks policy pragmas, determine the mode based on whether
-- assertions are enabled.
-- assertions are enabled at the configuration level. This ensures that
-- the policy is preserved when analyzing generics.
if Kind = No_Name then
if Assertions_Enabled then
if Assertions_Enabled_Config then
Kind := Name_Check;
else
Kind := Name_Ignore;