Skip to content

R
riscv-gcc-1
Commit 7b966a95 by Arnaud Charlet
Options

[multiple changes] 

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
parent 44ccf4b4
Showing with 281 additions and 96 deletions
gcc/ada/ChangeLog
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> 2014-07-17 Robert Dewar <dewar@adacore.com>
* g-comlin.ads, g-comlin.adb: Minor clean up. * g-comlin.ads, g-comlin.adb: Minor clean up.
......
gcc/ada/a-rbtgbk.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- --
...@@ -349,15 +349,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is ...@@ -349,15 +349,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is
N : Nodes_Type renames Tree.Nodes; N : Nodes_Type renames Tree.Nodes;
begin 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 if Tree.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (container is busy)"; "attempt to tamper with cursors (container is busy)";
end if; end if;
if Tree.Length >= Tree.Capacity then
raise Capacity_Error with "not enough capacity to insert new item";
end if;
Z := New_Node; Z := New_Node;
pragma Assert (Z /= 0); pragma Assert (Z /= 0);
......
gcc/ada/exp_ch7.adb
...@@ -2256,10 +2256,6 @@ package body Exp_Ch7 is ...@@ -2256,10 +2256,6 @@ package body Exp_Ch7 is
Last_Init : out Node_Id; Last_Init : out Node_Id;
Body_Insert : out Node_Id) Body_Insert : out Node_Id)
is is
Nod_1 : Node_Id := Empty;
Nod_2 : Node_Id := Empty;
Utyp : Entity_Id;
function Is_Init_Call function Is_Init_Call
(N : Node_Id; (N : Node_Id;
Typ : Entity_Id) return Boolean; Typ : Entity_Id) return Boolean;
...@@ -2332,6 +2328,14 @@ package body Exp_Ch7 is ...@@ -2332,6 +2328,14 @@ package body Exp_Ch7 is
return Result; return Result;
end Next_Suitable_Statement; 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 -- Start of processing for Find_Last_Init
begin begin
...@@ -2357,6 +2361,42 @@ package body Exp_Ch7 is ...@@ -2357,6 +2361,42 @@ package body Exp_Ch7 is
Utyp := Full_View (Utyp); Utyp := Full_View (Utyp);
end if; 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: -- The init procedures are arranged as follows:
-- Object : Controlled_Type; -- Object : Controlled_Type;
...@@ -2366,53 +2406,55 @@ package body Exp_Ch7 is ...@@ -2366,53 +2406,55 @@ package body Exp_Ch7 is
-- where the user-defined initialize may be optional or may appear -- where the user-defined initialize may be optional or may appear
-- inside a block when abort deferral is needed. -- inside a block when abort deferral is needed.
Nod_1 := Next_Suitable_Statement (Decl); else
if Present (Nod_1) then Nod_1 := Next_Suitable_Statement (Decl);
Nod_2 := Next_Suitable_Statement (Nod_1);
-- The statement following an object declaration is always a if Present (Nod_1) then
-- call to the type init proc. Nod_2 := Next_Suitable_Statement (Nod_1);
Last_Init := Nod_1; -- The statement following an object declaration is always a
end if; -- 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 if Present (Nod_2) then
-- statement in cases where abort deferral is required.
if Nkind (Nod_2) = N_Block_Statement then -- The statement following the type init proc may be a block
declare -- statement in cases where abort deferral is required.
HSS : constant Node_Id :=
Handled_Statement_Sequence (Nod_2);
Stmt : Node_Id;
begin if Nkind (Nod_2) = N_Block_Statement then
if Present (HSS) declare
and then Present (Statements (HSS)) HSS : constant Node_Id :=
then Handled_Statement_Sequence (Nod_2);
Stmt := First (Statements (HSS)); Stmt : Node_Id;
-- Examine individual block statements and locate the begin
-- call to [Deep_]Initialze. if Present (HSS)
and then Present (Statements (HSS))
then
-- Examine individual block statements and locate
-- the call to [Deep_]Initialze.
while Present (Stmt) loop Stmt := First (Statements (HSS));
if Is_Init_Call (Stmt, Utyp) then while Present (Stmt) loop
Last_Init := Stmt; if Is_Init_Call (Stmt, Utyp) then
Body_Insert := Nod_2; Last_Init := Stmt;
Body_Insert := Nod_2;
exit; exit;
end if; end if;
Next (Stmt); Next (Stmt);
end loop; end loop;
end if; end if;
end; end;
elsif Is_Init_Call (Nod_2, Utyp) then elsif Is_Init_Call (Nod_2, Utyp) then
Last_Init := Nod_2; Last_Init := Nod_2;
end if;
end if; end if;
end if; end if;
end Find_Last_Init; end Find_Last_Init;
...@@ -2434,7 +2476,7 @@ package body Exp_Ch7 is ...@@ -2434,7 +2476,7 @@ package body Exp_Ch7 is
-- Set a new value for the state counter and insert the statement -- Set a new value for the state counter and insert the statement
-- after the object declaration. Generate: -- after the object declaration. Generate:
--
-- Counter := <value>; -- Counter := <value>;
Inc_Decl := Inc_Decl :=
...@@ -2496,7 +2538,7 @@ package body Exp_Ch7 is ...@@ -2496,7 +2538,7 @@ package body Exp_Ch7 is
Label_Construct => Label)); Label_Construct => Label));
-- Create the associated jump with this object, generate: -- Create the associated jump with this object, generate:
--
-- when <counter> => -- when <counter> =>
-- goto L<counter>; -- goto L<counter>;
......
gcc/ada/exp_util.adb
...@@ -4794,6 +4794,79 @@ package body Exp_Util is ...@@ -4794,6 +4794,79 @@ package body Exp_Util is
and then not Is_Build_In_Place_Function_Call (Prefix (Expr)); and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
end Is_Non_BIP_Func_Call; 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 -- -- Is_Possibly_Unaligned_Object --
---------------------------------- ----------------------------------
...@@ -5183,7 +5256,11 @@ package body Exp_Util is ...@@ -5183,7 +5256,11 @@ package body Exp_Util is
-------------------------------------- --------------------------------------
function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean 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 begin
-- Build-in-place calls usually appear in 'reference format. Note that -- Build-in-place calls usually appear in 'reference format. Note that
...@@ -5201,49 +5278,40 @@ package body Exp_Util is ...@@ -5201,49 +5278,40 @@ package body Exp_Util is
end if; end if;
if Is_Build_In_Place_Function_Call (Call) then 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
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 -- Examine all parameter associations of the function call
-- 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 Param := First (Parameter_Associations (Call));
and then Present (Entity (Formal)) while Present (Param) loop
then if Nkind (Param) = N_Parameter_Association
Access_Nam := and then Nkind (Selector_Name (Param)) = N_Identifier
New_External_Name then
(Chars (Scope (Entity (Formal))), Formal := Selector_Name (Param);
BIP_Formal_Suffix (BIP_Alloc_Form)); Actual := Explicit_Actual_Parameter (Param);
end if;
-- 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 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;
-- A match for BIPalloc => 2 has been found -- A match for BIPalloc => 2 has been found
if Chars (Formal) = Access_Nam if Chars (Formal) = Alloc_Nam
and then Nkind (Actual) = N_Integer_Literal and then Nkind (Actual) = N_Integer_Literal
and then Intval (Actual) = Uint_2 and then Intval (Actual) = Uint_2
then then
return True; return True;
end if;
end if; end if;
end if;
Next (Param); Next (Param);
end loop; end loop;
end;
end if; end if;
return False; return False;
...@@ -5274,10 +5342,10 @@ package body Exp_Util is ...@@ -5274,10 +5342,10 @@ package body Exp_Util is
begin begin
return (not Is_Tagged_Type (T) and then Is_Derived_Type (T)) return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
or else or else
(Is_Private_Type (T) and then Present (Full_View (T)) (Is_Private_Type (T) and then Present (Full_View (T))
and then not Is_Tagged_Type (Full_View (T)) and then not Is_Tagged_Type (Full_View (T))
and then Is_Derived_Type (Full_View (T)) and then Is_Derived_Type (Full_View (T))
and then Etype (Full_View (T)) /= T); and then Etype (Full_View (T)) /= T);
end Is_Untagged_Derivation; end Is_Untagged_Derivation;
--------------------------- ---------------------------
......
gcc/ada/exp_util.ads
...@@ -127,6 +127,12 @@ package Exp_Util is ...@@ -127,6 +127,12 @@ package Exp_Util is
-- Assoc_Node must be a node in a list. Same as Insert_Action but the -- 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 -- action will be inserted after N in a manner that is compatible with
-- the transient scope mechanism. -- 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 procedure Insert_Actions_After
(Assoc_Node : Node_Id; (Assoc_Node : Node_Id;
...@@ -575,6 +581,12 @@ package Exp_Util is ...@@ -575,6 +581,12 @@ package Exp_Util is
function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
-- Determine whether node Expr denotes a non build-in-place function call -- 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; function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
-- Node N is an object reference. This function returns True if it is -- 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 -- possible that the object may not be aligned according to the normal
......
gcc/ada/gnatbind.adb
...@@ -672,7 +672,7 @@ begin ...@@ -672,7 +672,7 @@ begin
if Argument_Count = 0 then if Argument_Count = 0 then
Bindusg.Display; Bindusg.Display;
else else
Write_Line ("try `gnatbind --help` for more information."); Write_Line ("try ""gnatbind --help"" for more information.");
end if; end if;
Exit_Program (E_Fatal); Exit_Program (E_Fatal);
......
gcc/ada/sem_ch3.adb
...@@ -2366,11 +2366,14 @@ package body Sem_Ch3 is ...@@ -2366,11 +2366,14 @@ package body Sem_Ch3 is
-- Analyze the contracts of subprogram declarations, subprogram bodies -- Analyze the contracts of subprogram declarations, subprogram bodies
-- and variables now due to the delayed visibility requirements of their -- 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); Decl := First (L);
while Present (Decl) loop 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)); Analyze_Object_Contract (Defining_Entity (Decl));
elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration, elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
......
gcc/ada/sem_ch8.adb
...@@ -706,6 +706,14 @@ package body Sem_Ch8 is ...@@ -706,6 +706,14 @@ package body Sem_Ch8 is
Error_Msg_N ("within its scope, generic denotes its instance", N); Error_Msg_N ("within its scope, generic denotes its instance", N);
end if; 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); Check_Library_Unit_Renaming (N, Old_P);
end if; end if;
......
gcc/ada/sprint.adb
...@@ -2249,13 +2249,30 @@ package body Sprint is ...@@ -2249,13 +2249,30 @@ package body Sprint is
-- Print type, we used to print the Object_Definition from -- Print type, we used to print the Object_Definition from
-- the node, but it is much more useful to print the Etype -- the node, but it is much more useful to print the Etype
-- of the defining identifier. For example, this will be a -- of the defining identifier for the case where the nominal
-- clear reference to the Itype with the bounds in the case -- type is an unconstrained array type. For example, this
-- of an unconstrained array type like String. The object -- will be a clear reference to the Itype with the bounds
-- after all is constrained, even if its nominal subtype is -- in the case of a type like String. The object after
-- all is constrained, even if its nominal subtype is
-- unconstrained. -- 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 if Present (Expression (Node)) then
Write_Str (" := "); Write_Str (" := ");
......
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