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

[multiple changes]

Browse Source 
2014-07-17  Vincent Celier  <celier@adacore.com>

	* gnatbind.adb: Change in message "try ... for more information".

2014-07-17  Robert Dewar  <dewar@adacore.com>

	* sprint.adb: Code clean up.

2014-07-17  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Find_Last_Init): Relocate local variables to
	the relevant code section. Add new local constant Obj_Id. When
	a limited controlled object is initialized by a function call,
	the build-in-place object access function call acts as the last
	initialization statement.
	* exp_util.adb (Is_Object_Access_BIP_Func_Call): New routine.
	(Is_Secondary_Stack_BIP_Func_Call): Code reformatting.
	* exp_util.ads (Is_Object_Access_BIP_Func_Call): New routine.

2014-07-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Analyze_Generic_Renaming): For generic subprograms,
	propagate intrinsic flag to renamed entity, to allow e.g. renaming
	of Unchecked_Conversion.
	* sem_ch3.adb (Analyze_Declarations): Do not analyze contracts
	if the declaration has errors.

2014-07-17  Ed Schonberg  <schonberg@adacore.com>

	* a-rbtgbk.adb: a-rbtgbk.adb (Generic_Insert_Post): Check whether
	container is busy before checking whether capacity allows for
	a further insertion. Insertion in a busy container that is full
	raises Program_Error rather than Capacity_Error. Previous to that
	patch which exception was raised varied among container types.

From-SVN: r212730
This commit is contained in:
Arnaud Charlet 2014-07-17 08:52:30 +02:00
parent 44ccf4b458
commit 7b966a9546
9 changed files with 281 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gcc/ada/ChangeLog
View File

@ -1,3 +1,38 @@
2014-07-17 Vincent Celier <celier@adacore.com>
* gnatbind.adb: Change in message "try ... for more information".
2014-07-17 Robert Dewar <dewar@adacore.com>
* sprint.adb: Code clean up.
2014-07-17 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Find_Last_Init): Relocate local variables to
the relevant code section. Add new local constant Obj_Id. When
a limited controlled object is initialized by a function call,
the build-in-place object access function call acts as the last
initialization statement.
* exp_util.adb (Is_Object_Access_BIP_Func_Call): New routine.
(Is_Secondary_Stack_BIP_Func_Call): Code reformatting.
* exp_util.ads (Is_Object_Access_BIP_Func_Call): New routine.
2014-07-17 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Analyze_Generic_Renaming): For generic subprograms,
propagate intrinsic flag to renamed entity, to allow e.g. renaming
of Unchecked_Conversion.
* sem_ch3.adb (Analyze_Declarations): Do not analyze contracts
if the declaration has errors.
2014-07-17 Ed Schonberg <schonberg@adacore.com>
* a-rbtgbk.adb: a-rbtgbk.adb (Generic_Insert_Post): Check whether
container is busy before checking whether capacity allows for
a further insertion. Insertion in a busy container that is full
raises Program_Error rather than Capacity_Error. Previous to that
patch which exception was raised varied among container types.
2014-07-17 Robert Dewar <dewar@adacore.com>
* g-comlin.ads, g-comlin.adb: Minor clean up.

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

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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- --
@ -349,15 +349,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is
N : Nodes_Type renames Tree.Nodes;
begin
if Tree.Length >= Tree.Capacity then
raise Capacity_Error with "not enough capacity to insert new item";
end if;
if Tree.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
if Tree.Length >= Tree.Capacity then
raise Capacity_Error with "not enough capacity to insert new item";
end if;
Z := New_Node;
pragma Assert (Z /= 0);

124
gcc/ada/exp_ch7.adb
View File

@ -2256,10 +2256,6 @@ package body Exp_Ch7 is
Last_Init : out Node_Id;
Body_Insert : out Node_Id)
is
Nod_1 : Node_Id := Empty;
Nod_2 : Node_Id := Empty;
Utyp : Entity_Id;
function Is_Init_Call
(N : Node_Id;
Typ : Entity_Id) return Boolean;
@ -2332,6 +2328,14 @@ package body Exp_Ch7 is
return Result;
end Next_Suitable_Statement;
-- Local variables
Obj_Id : constant Entity_Id := Defining_Entity (Decl);
Nod_1 : Node_Id := Empty;
Nod_2 : Node_Id := Empty;
Stmt : Node_Id;
Utyp : Entity_Id;
-- Start of processing for Find_Last_Init
begin
@ -2357,6 +2361,42 @@ package body Exp_Ch7 is
Utyp := Full_View (Utyp);
end if;
-- A limited controlled object initialized by a function call uses
-- the build-in-place machinery to obtain its value.
-- Obj : Lim_Controlled_Type := Func_Call;
-- is expanded into
-- Obj : Lim_Controlled_Type;
-- type Ptr_Typ is access Lim_Controlled_Type;
-- Temp : constant Ptr_Typ :=
-- Func_Call
-- (BIPalloc => 1,
-- BIPaccess => Obj'Unrestricted_Access)'reference;
-- In this scenario the declaration of the temporary acts as the
-- last initialization statement.
if Is_Limited_Type (Utyp)
and then Has_Init_Expression (Decl)
and then No (Expression (Decl))
then
Stmt := Next (Decl);
while Present (Stmt) loop
if Nkind (Stmt) = N_Object_Declaration
and then Present (Expression (Stmt))
and then Is_Object_Access_BIP_Func_Call
(Expr => Expression (Stmt),
Obj_Id => Obj_Id)
then
Last_Init := Stmt;
exit;
end if;
Next (Stmt);
end loop;
-- The init procedures are arranged as follows:
-- Object : Controlled_Type;
@ -2366,53 +2406,55 @@ package body Exp_Ch7 is
-- where the user-defined initialize may be optional or may appear
-- inside a block when abort deferral is needed.
Nod_1 := Next_Suitable_Statement (Decl);
if Present (Nod_1) then
Nod_2 := Next_Suitable_Statement (Nod_1);
else
Nod_1 := Next_Suitable_Statement (Decl);
-- The statement following an object declaration is always a
-- call to the type init proc.
if Present (Nod_1) then
Nod_2 := Next_Suitable_Statement (Nod_1);
Last_Init := Nod_1;
end if;
-- The statement following an object declaration is always a
-- call to the type init proc.
-- Optional user-defined init or deep init processing
Last_Init := Nod_1;
end if;
if Present (Nod_2) then
-- Optional user-defined init or deep init processing
-- The statement following the type init proc may be a block
-- statement in cases where abort deferral is required.
if Present (Nod_2) then
if Nkind (Nod_2) = N_Block_Statement then
declare
HSS : constant Node_Id :=
Handled_Statement_Sequence (Nod_2);
Stmt : Node_Id;
-- The statement following the type init proc may be a block
-- statement in cases where abort deferral is required.
begin
if Present (HSS)
and then Present (Statements (HSS))
then
Stmt := First (Statements (HSS));
if Nkind (Nod_2) = N_Block_Statement then
declare
HSS : constant Node_Id :=
Handled_Statement_Sequence (Nod_2);
Stmt : Node_Id;
-- Examine individual block statements and locate the
-- call to [Deep_]Initialze.
begin
if Present (HSS)
and then Present (Statements (HSS))
then
-- Examine individual block statements and locate
-- the call to [Deep_]Initialze.
while Present (Stmt) loop
if Is_Init_Call (Stmt, Utyp) then
Last_Init := Stmt;
Body_Insert := Nod_2;
Stmt := First (Statements (HSS));
while Present (Stmt) loop
if Is_Init_Call (Stmt, Utyp) then
Last_Init := Stmt;
Body_Insert := Nod_2;
exit;
end if;
exit;
end if;
Next (Stmt);
end loop;
end if;
end;
Next (Stmt);
end loop;
end if;
end;
elsif Is_Init_Call (Nod_2, Utyp) then
Last_Init := Nod_2;
elsif Is_Init_Call (Nod_2, Utyp) then
Last_Init := Nod_2;
end if;
end if;
end if;
end Find_Last_Init;
@ -2434,7 +2476,7 @@ package body Exp_Ch7 is
-- Set a new value for the state counter and insert the statement
-- after the object declaration. Generate:
--
-- Counter := <value>;
Inc_Decl :=
@ -2496,7 +2538,7 @@ package body Exp_Ch7 is
Label_Construct => Label));
-- Create the associated jump with this object, generate:
--
-- when <counter> =>
-- goto L<counter>;

152
gcc/ada/exp_util.adb
View File

@ -4794,6 +4794,79 @@ package body Exp_Util is
and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
end Is_Non_BIP_Func_Call;
------------------------------------
-- Is_Object_Access_BIP_Func_Call --
------------------------------------
function Is_Object_Access_BIP_Func_Call
(Expr : Node_Id;
Obj_Id : Entity_Id) return Boolean
is
Access_Nam : Name_Id := No_Name;
Actual : Node_Id;
Call : Node_Id;
Formal : Node_Id;
Param : Node_Id;
begin
-- Build-in-place calls usually appear in 'reference format. Note that
-- the accessibility check machinery may add an extra 'reference due to
-- side effect removal.
Call := Expr;
while Nkind (Call) = N_Reference loop
Call := Prefix (Call);
end loop;
if Nkind_In (Call, N_Qualified_Expression,
N_Unchecked_Type_Conversion)
then
Call := Expression (Call);
end if;
if Is_Build_In_Place_Function_Call (Call) then
-- Examine all parameter associations of the function call
Param := First (Parameter_Associations (Call));
while Present (Param) loop
if Nkind (Param) = N_Parameter_Association
and then Nkind (Selector_Name (Param)) = N_Identifier
then
Formal := Selector_Name (Param);
Actual := Explicit_Actual_Parameter (Param);
-- Construct the name of formal BIPaccess. It is much easier to
-- extract the name of the function using an arbitrary formal's
-- scope rather than the Name field of Call.
if Access_Nam = No_Name and then Present (Entity (Formal)) then
Access_Nam :=
New_External_Name
(Chars (Scope (Entity (Formal))),
BIP_Formal_Suffix (BIP_Object_Access));
end if;
-- A match for BIPaccess => Obj_Id'Unrestricted_Access has been
-- found.
if Chars (Formal) = Access_Nam
and then Nkind (Actual) = N_Attribute_Reference
and then Attribute_Name (Actual) = Name_Unrestricted_Access
and then Nkind (Prefix (Actual)) = N_Identifier
and then Entity (Prefix (Actual)) = Obj_Id
then
return True;
end if;
end if;
Next (Param);
end loop;
end if;
return False;
end Is_Object_Access_BIP_Func_Call;
----------------------------------
-- Is_Possibly_Unaligned_Object --
----------------------------------
@ -5183,7 +5256,11 @@ package body Exp_Util is
--------------------------------------
function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
Call : Node_Id := Expr;
Alloc_Nam : Name_Id := No_Name;
Actual : Node_Id;
Call : Node_Id := Expr;
Formal : Node_Id;
Param : Node_Id;
begin
-- Build-in-place calls usually appear in 'reference format. Note that
@ -5201,49 +5278,40 @@ package body Exp_Util is
end if;
if Is_Build_In_Place_Function_Call (Call) then
declare
Access_Nam : Name_Id := No_Name;
Actual : Node_Id;
Param : Node_Id;
Formal : Node_Id;
begin
-- Examine all parameter associations of the function call
-- Examine all parameter associations of the function call
Param := First (Parameter_Associations (Call));
while Present (Param) loop
if Nkind (Param) = N_Parameter_Association
and then Nkind (Selector_Name (Param)) = N_Identifier
then
Formal := Selector_Name (Param);
Actual := Explicit_Actual_Parameter (Param);
Param := First (Parameter_Associations (Call));
while Present (Param) loop
if Nkind (Param) = N_Parameter_Association
and then Nkind (Selector_Name (Param)) = N_Identifier
then
Formal := Selector_Name (Param);
Actual := Explicit_Actual_Parameter (Param);
-- Construct the name of formal BIPalloc. It is much easier
-- to extract the name of the function using an arbitrary
-- formal's scope rather than the Name field of Call.
-- Construct the name of formal BIPalloc. It is much easier to
-- extract the name of the function using an arbitrary formal's
-- scope rather than the Name field of Call.
if Access_Nam = No_Name
and then Present (Entity (Formal))
then
Access_Nam :=
New_External_Name
(Chars (Scope (Entity (Formal))),
BIP_Formal_Suffix (BIP_Alloc_Form));
end if;
-- A match for BIPalloc => 2 has been found
if Chars (Formal) = Access_Nam
and then Nkind (Actual) = N_Integer_Literal
and then Intval (Actual) = Uint_2
then
return True;
end if;
if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
Alloc_Nam :=
New_External_Name
(Chars (Scope (Entity (Formal))),
BIP_Formal_Suffix (BIP_Alloc_Form));
end if;
Next (Param);
end loop;
end;
-- A match for BIPalloc => 2 has been found
if Chars (Formal) = Alloc_Nam
and then Nkind (Actual) = N_Integer_Literal
and then Intval (Actual) = Uint_2
then
return True;
end if;
end if;
Next (Param);
end loop;
end if;
return False;
@ -5274,10 +5342,10 @@ package body Exp_Util is
begin
return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
or else
(Is_Private_Type (T) and then Present (Full_View (T))
and then not Is_Tagged_Type (Full_View (T))
and then Is_Derived_Type (Full_View (T))
and then Etype (Full_View (T)) /= T);
(Is_Private_Type (T) and then Present (Full_View (T))
and then not Is_Tagged_Type (Full_View (T))
and then Is_Derived_Type (Full_View (T))
and then Etype (Full_View (T)) /= T);
end Is_Untagged_Derivation;
---------------------------

12
gcc/ada/exp_util.ads
View File

@ -127,6 +127,12 @@ package Exp_Util is
-- Assoc_Node must be a node in a list. Same as Insert_Action but the
-- action will be inserted after N in a manner that is compatible with
-- the transient scope mechanism.
--
-- Note: If several successive calls to Insert_Action_After are made for
-- the same node, they will each in turn be inserted just after the node.
-- This means they will end up being executed in reverse order. Use the
-- call to Insert_Actions_After to insert a list of actions to be executed
-- in the sequence in which they are given in the list.
procedure Insert_Actions_After
(Assoc_Node : Node_Id;
@ -575,6 +581,12 @@ package Exp_Util is
function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
-- Determine whether node Expr denotes a non build-in-place function call
function Is_Object_Access_BIP_Func_Call
(Expr : Node_Id;
Obj_Id : Entity_Id) return Boolean;
-- Determine if Expr denotes a build-in-place function which stores its
-- result in the BIPaccess actual parameter whose prefix must match Obj_Id.
function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
-- Node N is an object reference. This function returns True if it is
-- possible that the object may not be aligned according to the normal

2
gcc/ada/gnatbind.adb
View File

@ -672,7 +672,7 @@ begin
if Argument_Count = 0 then
Bindusg.Display;
else
Write_Line ("try `gnatbind --help` for more information.");
Write_Line ("try ""gnatbind --help"" for more information.");
end if;
Exit_Program (E_Fatal);

7
gcc/ada/sem_ch3.adb
View File

@ -2366,11 +2366,14 @@ package body Sem_Ch3 is
-- Analyze the contracts of subprogram declarations, subprogram bodies
-- and variables now due to the delayed visibility requirements of their
-- aspects.
-- aspects. Skip analysis if the declaration already has an error.
Decl := First (L);
while Present (Decl) loop
if Nkind (Decl) = N_Object_Declaration then
if Error_Posted (Decl) then
null;
elsif Nkind (Decl) = N_Object_Declaration then
Analyze_Object_Contract (Defining_Entity (Decl));
elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,

8
gcc/ada/sem_ch8.adb
View File

@ -706,6 +706,14 @@ package body Sem_Ch8 is
Error_Msg_N ("within its scope, generic denotes its instance", N);
end if;
-- For subprograms, propagate the Intrinsic flag, to allow, e.g.
-- renamings and subsequent instantiations of Unchecked_Conversion.
if Ekind_In (Old_P, E_Generic_Function, E_Generic_Procedure) then
Set_Is_Intrinsic_Subprogram
(New_P, Is_Intrinsic_Subprogram (Old_P));
end if;
Check_Library_Unit_Renaming (N, Old_P);
end if;

27
gcc/ada/sprint.adb
View File

@ -2249,13 +2249,30 @@ package body Sprint is
-- Print type, we used to print the Object_Definition from
-- the node, but it is much more useful to print the Etype
-- of the defining identifier. For example, this will be a
-- clear reference to the Itype with the bounds in the case
-- of an unconstrained array type like String. The object
-- after all is constrained, even if its nominal subtype is
-- of the defining identifier for the case where the nominal
-- type is an unconstrained array type. For example, this
-- will be a clear reference to the Itype with the bounds
-- in the case of a type like String. The object after
-- all is constrained, even if its nominal subtype is
-- unconstrained.
Sprint_Node (Etype (Def_Id));
declare
Odef : constant Node_Id := Object_Definition (Node);
begin
if Nkind (Odef) = N_Identifier
and then Is_Array_Type (Etype (Odef))
and then not Is_Constrained (Etype (Odef))
and then Present (Etype (Def_Id))
then
Sprint_Node (Etype (Def_Id));
-- In other cases, the nominal type is fine to print
else
Sprint_Node (Odef);
end if;
end;
if Present (Expression (Node)) then
Write_Str (" := ");