Skip to content

R
riscv-gcc-1
Commit fb9dd1c7 by Pierre-Marie de Rodat
Options

[multiple changes] 

2017-10-19  Bob Duff  <duff@adacore.com>

	* exp_util.adb: (Process_Statements_For_Controlled_Objects): Clarify
	which node kinds can legitimately be ignored, and raise Program_Error
	for others.

2017-10-19  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_elab.adb (Compilation_Unit): Handle the case of a subprogram
	instantiation that acts as a compilation unit.
	(Find_Code_Unit): Reimplemented.
	(Find_Top_Unit): Reimplemented.
	(Find_Unit_Entity): New routine.
	(Process_Instantiation_SPARK): Correct the elaboration requirement a
	package instantiation imposes on a unit.

2017-10-19  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb (Is_Build_In_Place_Result_Type): Enable build-in-place
	for a narrow set of controlled types.

2017-10-19  Eric Botcazou  <ebotcazou@adacore.com>

	* sinput.ads (Line_Start): Add pragma Inline.
	* widechar.ads (Is_Start_Of_Wide_Char): Likewise.

2017-10-19  Bob Duff  <duff@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Disable
	Make_Build_In_Place_Call_... for F(...)'Old, where F(...) is a
	build-in-place function call so that the temp is declared in the right
	place.

From-SVN: r253915
parent ebd208bf
Showing with 164 additions and 34 deletions
gcc/ada/ChangeLog
2017-10-19 Bob Duff <duff@adacore.com>
* exp_util.adb: (Process_Statements_For_Controlled_Objects): Clarify
which node kinds can legitimately be ignored, and raise Program_Error
for others.
2017-10-19 Hristian Kirtchev <kirtchev@adacore.com>
* sem_elab.adb (Compilation_Unit): Handle the case of a subprogram
instantiation that acts as a compilation unit.
(Find_Code_Unit): Reimplemented.
(Find_Top_Unit): Reimplemented.
(Find_Unit_Entity): New routine.
(Process_Instantiation_SPARK): Correct the elaboration requirement a
package instantiation imposes on a unit.
2017-10-19 Bob Duff <duff@adacore.com>
* exp_ch6.adb (Is_Build_In_Place_Result_Type): Enable build-in-place
for a narrow set of controlled types.
2017-10-19 Eric Botcazou <ebotcazou@adacore.com>
* sinput.ads (Line_Start): Add pragma Inline.
* widechar.ads (Is_Start_Of_Wide_Char): Likewise.
2017-10-19 Bob Duff <duff@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference): Disable
Make_Build_In_Place_Call_... for F(...)'Old, where F(...) is a
build-in-place function call so that the temp is declared in the right
place.
2017-10-18 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/misc.c (gnat_tree_size): Move around.
......
gcc/ada/exp_attr.adb
......@@ -1756,7 +1756,19 @@ package body Exp_Attr is
-- and access to it must be passed to the function.
if Is_Build_In_Place_Function_Call (Pref) then
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
-- If attribute is 'Old, the context is a postcondition, and
-- the temporary must go in the corresponding subprogram, not
-- the postcondition function or any created blocks, as when
-- the attribute appears in a quantified expression. This is
-- handled below in the expansion of the attribute.
if Attribute_Name (Parent (Pref)) = Name_Old then
null;
else
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
end if;
-- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
-- containing build-in-place function calls whose returned object covers
......
gcc/ada/exp_ch6.adb
......@@ -7240,34 +7240,58 @@ package body Exp_Ch6 is
if Is_Limited_View (Typ) then
return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
else
-- if Debug_Flag_Dot_9 then
if True then
return False; -- ???disable bip for nonlimited types
end if;
if Has_Interfaces (Typ) then
return False;
end if;
-- For T'Class, return True if it's True for the corresponding
-- specific type. This is necessary because a class-wide function
-- might say "return F (...)", where F returns the corresponding
-- specific type.
if Is_Class_Wide_Type (Typ) then
return Is_Build_In_Place_Result_Type (Etype (Typ));
end if;
declare
T : Entity_Id := Typ;
begin
if Present (Underlying_Type (Typ)) then
-- For T'Class, return True if it's True for T. This is necessary
-- because a class-wide function might say "return F (...)", where
-- F returns the corresponding specific type.
if Is_Class_Wide_Type (Typ) then
T := Etype (Typ);
end if;
-- If this is a generic formal type in an instance, return True if
-- it's True for the generic actual type.
if Nkind (Parent (Typ)) = N_Subtype_Declaration
and then Present (Generic_Parent_Type (Parent (Typ)))
then
T := Entity (Subtype_Indication (Parent (Typ)));
if Present (Full_View (T)) then
T := Full_View (T);
end if;
elsif Present (Underlying_Type (Typ)) then
T := Underlying_Type (Typ);
end if;
declare
Result : constant Boolean := Is_Controlled (T);
Result : Boolean;
begin
-- ???For now, enable build-in-place for a very narrow set of
-- controlled types. Change "if True" to "if False" to
-- experiment more controlled types. Eventually, we would
-- like to enable build-in-place for all tagged types, all
-- types that need finalization, and all caller-unknown-size
-- types. We will eventually use Debug_Flag_Dot_9 to disable
-- build-in-place for nonlimited types.
-- if Debug_Flag_Dot_9 then
if True then
Result := Is_Controlled (T)
and then Present (Enclosing_Subprogram (T))
and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
else
Result := Is_Controlled (T);
end if;
return Result;
end;
end;
......
gcc/ada/exp_util.adb
......@@ -10817,8 +10817,14 @@ package body Exp_Util is
Analyze (Block);
end if;
when others =>
-- Could be e.g. a loop that was transformed into a block or null
-- statement. Do nothing for terminate alternatives.
when N_Block_Statement | N_Null_Statement | N_Terminate_Alternative =>
null;
when others =>
raise Program_Error;
end case;
end Process_Statements_For_Controlled_Objects;
......
gcc/ada/sem_elab.adb
......@@ -159,7 +159,7 @@ package body Sem_Elab is
--
-- - Instantiations
--
-- - References to variables
-- - Reads of variables
--
-- - Task activation
--
......@@ -175,7 +175,7 @@ package body Sem_Elab is
--
-- - For instantiations, the target is the generic template
--
-- - For references to variables, the target is the variable
-- - For reads of variables, the target is the variable
--
-- - For task activation, the target is the task body
--
......@@ -883,6 +883,10 @@ package body Sem_Elab is
-- is obtained by logically unwinding instantiations and subunits when N
-- resides within one.
function Find_Unit_Entity (N : Node_Id) return Entity_Id;
pragma Inline (Find_Unit_Entity);
-- Return the entity of unit N
function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id;
pragma Inline (First_Formal_Type);
-- Return the type of subprogram Subp_Id's first formal parameter. If the
......@@ -1904,7 +1908,20 @@ package body Sem_Elab is
Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id));
end if;
if Nkind (Comp_Unit) = N_Subunit then
-- Handle the case where a subprogram instantiation which acts as a
-- compilation unit is expanded into an anonymous package that wraps
-- the instantiated subprogram.
if Nkind (Comp_Unit) = N_Package_Specification
and then Nkind_In (Original_Node (Parent (Comp_Unit)),
N_Function_Instantiation,
N_Procedure_Instantiation)
then
Comp_Unit := Parent (Parent (Comp_Unit));
-- Handle the case where the compilation unit is a subunit
elsif Nkind (Comp_Unit) = N_Subunit then
Comp_Unit := Parent (Comp_Unit);
end if;
......@@ -2933,10 +2950,8 @@ package body Sem_Elab is
--------------------
function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is
N_Unit : constant Node_Id := Unit (Cunit (Get_Code_Unit (N)));
begin
return Defining_Entity (N_Unit, Concurrent_Subunit => True);
return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N))));
end Find_Code_Unit;
---------------------------
......@@ -3405,12 +3420,47 @@ package body Sem_Elab is
-------------------
function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is
N_Unit : constant Node_Id := Unit (Cunit (Get_Top_Level_Code_Unit (N)));
begin
return Defining_Entity (N_Unit, Concurrent_Subunit => True);
return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N))));
end Find_Top_Unit;
----------------------
-- Find_Unit_Entity --
----------------------
function Find_Unit_Entity (N : Node_Id) return Entity_Id is
Context : constant Node_Id := Parent (N);
Orig_N : constant Node_Id := Original_Node (N);
begin
-- The unit denotes a package body of an instantiation which acts as
-- a compilation unit. The proper entity is that of the package spec.
if Nkind (N) = N_Package_Body
and then Nkind (Orig_N) = N_Package_Instantiation
and then Nkind (Context) = N_Compilation_Unit
then
return Corresponding_Spec (N);
-- The unit denotes an anonymous package created to wrap a subprogram
-- instantiation which acts as a compilation unit. The proper entity is
-- that of the "related instance".
elsif Nkind (N) = N_Package_Declaration
and then Nkind_In (Orig_N, N_Function_Instantiation,
N_Procedure_Instantiation)
and then Nkind (Context) = N_Compilation_Unit
then
return
Related_Instance (Defining_Entity (N, Concurrent_Subunit => True));
-- Otherwise the proper entity is the defining entity
else
return Defining_Entity (N, Concurrent_Subunit => True);
end if;
end Find_Unit_Entity;
-----------------------
-- First_Formal_Type --
-----------------------
......@@ -5335,8 +5385,8 @@ package body Sem_Elab is
-- in a great number of contexts. To determine whether a reference is
-- a read, it is more practical to find out whether it is a write.
-- A reference is a write when appearing immediately on the left-hand
-- side of an assignment.
-- A reference is a write when it appears immediately on the left-
-- hand side of an assignment.
if Nkind (Context) = N_Assignment_Statement
and then Name (Context) = Ref
......@@ -7796,9 +7846,9 @@ package body Sem_Elab is
-- ABE ramifications of the instantiation.
if Nkind (Inst) = N_Package_Instantiation then
Req_Nam := Name_Elaborate;
else
Req_Nam := Name_Elaborate_All;
else
Req_Nam := Name_Elaborate;
end if;
Meet_Elaboration_Requirement
......@@ -8155,10 +8205,10 @@ package body Sem_Elab is
-- listed below are not considered. The categories are:
-- 'Access for entries, operators, and subprograms
-- Assignments to variables
-- Calls (includes task activation)
-- Instantiations
-- Variable assignments
-- Variable references
-- Reads of variables
elsif Is_Suitable_Access (N)
or else Is_Suitable_Variable_Assignment (N)
......
gcc/ada/sinput.ads
......@@ -755,6 +755,8 @@ private
pragma Inline (Num_Source_Files);
pragma Inline (Num_Source_Lines);
pragma Inline (Line_Start);
No_Instance_Id : constant Instance_Id := 0;
-------------------------
......
gcc/ada/widechar.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
......@@ -95,4 +95,7 @@ package Widechar is
P : Source_Ptr) return Boolean;
-- Determines if S (P) is the start of a wide character sequence
private
pragma Inline (Is_Start_Of_Wide_Char);
end Widechar;
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