Skip to content

R
riscv-gcc-1
Commit e7c25229 by Arnaud Charlet
Options

[multiple changes] 

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_aux.adb (Nearest_Ancestor): Use original node of type
	declaration to locate nearest ancestor, because derived
	type declarations for record types are rewritten as record
	declarations.
	* sem_ch13.adb (Add_Call): Use an unchecked conversion to handle
	properly derivations that are completions of private types.
	(Add_Predicates): If type is private, examine rep. items of full
	view, which may include inherited predicates.
	(Build_Predicate_Functions): Ditto.

2017-04-25  Javier Miranda  <miranda@adacore.com>

	* sem_util.adb (New_Copy_Tree.Visit_Entity): Extend previous change
	to generate new entities for subtype declarations located in
	Expression_With_Action nodes.

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_elab.adb (Check_A_Call): Remove
	local variables Is_DIC_Proc and Issue_In_SPARK. Verify the
	need for Elaborate_All when SPARK elaboration checks are
	required. Update the checks for instances, variables, and calls
	to Default_Initial_Condition procedures.

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* aspects.ads, aspects.adb: Make the GNAT-specific pragma No_Inline
	into a boolean aspect, in analogy with the Ada aspect No_Return.

From-SVN: r247219
parent a267d8cc
Showing with 108 additions and 62 deletions
gcc/ada/ChangeLog
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_aux.adb (Nearest_Ancestor): Use original node of type
declaration to locate nearest ancestor, because derived
type declarations for record types are rewritten as record
declarations.
* sem_ch13.adb (Add_Call): Use an unchecked conversion to handle
properly derivations that are completions of private types.
(Add_Predicates): If type is private, examine rep. items of full
view, which may include inherited predicates.
(Build_Predicate_Functions): Ditto.
2017-04-25 Javier Miranda <miranda@adacore.com>
* sem_util.adb (New_Copy_Tree.Visit_Entity): Extend previous change
to generate new entities for subtype declarations located in
Expression_With_Action nodes.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* sem_elab.adb (Check_A_Call): Remove
local variables Is_DIC_Proc and Issue_In_SPARK. Verify the
need for Elaborate_All when SPARK elaboration checks are
required. Update the checks for instances, variables, and calls
to Default_Initial_Condition procedures.
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* aspects.ads, aspects.adb: Make the GNAT-specific pragma No_Inline
into a boolean aspect, in analogy with the Ada aspect No_Return.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch6.adb, sem_ch13.adb, sem_ch6.adb: Minor reformatting.
......
gcc/ada/aspects.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- Copyright (C) 2010-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- --
......@@ -570,6 +570,7 @@ package body Aspects is
Aspect_Machine_Radix => Aspect_Machine_Radix,
Aspect_Max_Queue_Length => Aspect_Max_Queue_Length,
Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
Aspect_No_Inline => Aspect_No_Inline,
Aspect_No_Return => Aspect_No_Return,
Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams,
Aspect_Obsolescent => Aspect_Obsolescent,
......
gcc/ada/aspects.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- Copyright (C) 2010-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- --
......@@ -189,6 +189,7 @@ package Aspects is
Aspect_Inline_Always, -- GNAT
Aspect_Interrupt_Handler,
Aspect_Lock_Free, -- GNAT
Aspect_No_Inline, -- GNAT
Aspect_No_Return,
Aspect_No_Tagged_Streams, -- GNAT
Aspect_Pack,
......@@ -468,6 +469,7 @@ package Aspects is
Aspect_Machine_Radix => Name_Machine_Radix,
Aspect_Max_Queue_Length => Name_Max_Queue_Length,
Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All,
Aspect_No_Inline => Name_No_Inline,
Aspect_No_Return => Name_No_Return,
Aspect_No_Tagged_Streams => Name_No_Tagged_Streams,
Aspect_Object_Size => Name_Object_Size,
......@@ -677,6 +679,7 @@ package Aspects is
Aspect_Link_Name => Always_Delay,
Aspect_Linker_Section => Always_Delay,
Aspect_Lock_Free => Always_Delay,
Aspect_No_Inline => Always_Delay,
Aspect_No_Return => Always_Delay,
Aspect_Output => Always_Delay,
Aspect_Persistent_BSS => Always_Delay,
......
gcc/ada/sem_aux.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, 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- --
......@@ -1295,7 +1295,10 @@ package body Sem_Aux is
----------------------
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
D : constant Node_Id := Declaration_Node (Typ);
D : constant Node_Id := Original_Node (Declaration_Node (Typ));
-- We use the original node of the declaration, because derived
-- types from record subtypes are rewritten as record declarations,
-- and it is the original declaration that carries the ancestor.
begin
-- If we have a subtype declaration, get the ancestor subtype
......
gcc/ada/sem_ch13.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, 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- --
......@@ -8309,11 +8309,15 @@ package body Sem_Ch13 is
if Present (T) and then Present (Predicate_Function (T)) then
Set_Has_Predicates (Typ);
-- Build the call to the predicate function of T
-- Build the call to the predicate function of T. The type may be
-- derived, so use an unchecked conversion for the actual.
Exp :=
Make_Predicate_Call
(T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
(Typ => T,
Expr =>
Unchecked_Convert_To (T,
Make_Identifier (Loc, Object_Name)));
-- "and"-in the call to evolving expression
......@@ -8456,6 +8460,14 @@ package body Sem_Ch13 is
begin
Ritem := First_Rep_Item (Typ);
-- If the type is private, check whether full view has inherited
-- predicates.
if Is_Private_Type (Typ) and then No (Ritem) then
Ritem := First_Rep_Item (Full_View (Typ));
end if;
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
......@@ -8562,8 +8574,16 @@ package body Sem_Ch13 is
-- ones for the current type, as required by AI12-0071-1.
declare
Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
Atyp : Entity_Id;
begin
Atyp := Nearest_Ancestor (Typ);
-- The type may be private but the full view may inherit predicates
if No (Atyp) and then Is_Private_Type (Typ) then
Atyp := Nearest_Ancestor (Full_View (Typ));
end if;
if Present (Atyp) then
Add_Call (Atyp);
end if;
......
gcc/ada/sem_elab.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1997-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- --
......@@ -629,7 +629,18 @@ package body Sem_Elab is
return W_Scope;
end Find_W_Scope;
-- Locals
-- Local variables
Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
-- Indicates if we have instantiation case
Loc : constant Source_Ptr := Sloc (N);
SPARK_Elab_Errors : constant Boolean :=
SPARK_Mode = On
and then Dynamic_Elaboration_Checks;
-- Flag set when an entity is called or a variable is read during SPARK
-- dynamic elaboration.
Variable_Case : constant Boolean :=
Nkind (N) in N_Has_Entity
......@@ -637,10 +648,17 @@ package body Sem_Elab is
and then Ekind (Entity (N)) = E_Variable;
-- Indicates if we have variable reference case
Loc : constant Source_Ptr := Sloc (N);
Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
-- Indicates if we have instantiation case
W_Scope : constant Entity_Id := Find_W_Scope;
-- Top-level scope of directly called entity for subprogram. This
-- differs from E_Scope in the case where renamings or derivations
-- are involved, since it does not follow these links. W_Scope is
-- generally in a visible unit, and it is this scope that may require
-- an Elaborate_All. However, there are some cases (initialization
-- calls and calls involving object notation) where W_Scope might not
-- be in the context of the current unit, and there is an intermediate
-- package that is, in which case the Elaborate_All has to be placed
-- on this intermediate package. These special cases are handled in
-- Set_Elaboration_Constraint.
Ent : Entity_Id;
Callee_Unit_Internal : Boolean;
......@@ -667,26 +685,6 @@ package body Sem_Elab is
-- non-visible unit. This is the scope that is to be investigated to
-- see whether an elaboration check is required.
Is_DIC_Proc : Boolean := False;
-- Flag set when the call denotes the Default_Initial_Condition
-- procedure of a private type that wraps a nontrivial assertion
-- expression.
Issue_In_SPARK : Boolean;
-- Flag set when a source entity is called during elaboration in SPARK
W_Scope : constant Entity_Id := Find_W_Scope;
-- Top-level scope of directly called entity for subprogram. This
-- differs from E_Scope in the case where renamings or derivations
-- are involved, since it does not follow these links. W_Scope is
-- generally in a visible unit, and it is this scope that may require
-- an Elaborate_All. However, there are some cases (initialization
-- calls and calls involving object notation) where W_Scope might not
-- be in the context of the current unit, and there is an intermediate
-- package that is, in which case the Elaborate_All has to be placed
-- on this intermediate package. These special cases are handled in
-- Set_Elaboration_Constraint.
-- Start of processing for Check_A_Call
begin
......@@ -1019,33 +1017,19 @@ package body Sem_Elab is
return;
end if;
Is_DIC_Proc := Is_Nontrivial_DIC_Procedure (Ent);
-- Elaboration issues in SPARK are reported only for source constructs
-- and for nontrivial Default_Initial_Condition procedures. The latter
-- must be checked because the default initialization of an object of a
-- private type triggers the evaluation of the Default_Initial_Condition
-- expression, which in turn may have side effects.
Issue_In_SPARK :=
SPARK_Mode = On
and then Dynamic_Elaboration_Checks
and then (Comes_From_Source (Ent) or Is_DIC_Proc);
-- Now check if an Elaborate_All (or dynamic check) is needed
if not Suppress_Elaboration_Warnings (Ent)
if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors)
and then Generate_Warnings
and then not Suppress_Elaboration_Warnings (Ent)
and then not Elaboration_Checks_Suppressed (Ent)
and then not Suppress_Elaboration_Warnings (E_Scope)
and then not Elaboration_Checks_Suppressed (E_Scope)
and then ((Elab_Warnings or Elab_Info_Messages)
or else SPARK_Mode = On)
and then Generate_Warnings
then
-- Instantiation case
if Inst_Case then
if Issue_In_SPARK then
if Comes_From_Source (Ent) and then SPARK_Elab_Errors then
Error_Msg_NE
("instantiation of & during elaboration in SPARK", N, Ent);
else
......@@ -1063,9 +1047,11 @@ package body Sem_Elab is
-- Variable reference in SPARK mode
elsif Variable_Case and Issue_In_SPARK then
Error_Msg_NE
("reference to & during elaboration in SPARK", N, Ent);
elsif Variable_Case then
if Comes_From_Source (Ent) and then SPARK_Elab_Errors then
Error_Msg_NE
("reference to & during elaboration in SPARK", N, Ent);
end if;
-- Subprogram call case
......@@ -1079,14 +1065,14 @@ package body Sem_Elab is
"info: implicit call to & during elaboration?$?",
Ent);
elsif Issue_In_SPARK then
elsif SPARK_Elab_Errors then
-- Emit a specialized error message when the elaboration of an
-- object of a private type evaluates the expression of pragma
-- Default_Initial_Condition. This prevents the internal name
-- of the procedure from appearing in the error message.
if Is_DIC_Proc then
if Is_Nontrivial_DIC_Procedure (Ent) then
Error_Msg_N
("call to Default_Initial_Condition during elaboration in "
& "SPARK", N);
......@@ -1108,7 +1094,7 @@ package body Sem_Elab is
-- Case of Elaborate_All not present and required, for SPARK this
-- is an error, so give an error message.
if Issue_In_SPARK then
if SPARK_Elab_Errors then
Error_Msg_NE -- CODEFIX
("\Elaborate_All pragma required for&", N, W_Scope);
......
gcc/ada/sem_util.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, 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- --
......@@ -17120,10 +17120,12 @@ package body Sem_Util is
pragma Assert (not Is_Itype (Old_Entity));
pragma Assert (Nkind (Old_Entity) in N_Entity);
-- Restrict entity creation to variable declarations. There is no
-- need to create variables declared in inner scopes.
-- Restrict entity creation to declarations of constants, variables
-- and subtypes. There is no need to duplicate entities declared in
-- inner scopes.
if not Ekind_In (Old_Entity, E_Constant, E_Variable)
if (not Ekind_In (Old_Entity, E_Constant, E_Variable)
and then Nkind (Parent (Old_Entity)) /= N_Subtype_Declaration)
or else EWA_Inner_Scope_Level > 0
then
return;
......
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