+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.
-- --
-- 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- --
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,
-- --
-- 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- --
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,
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,
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,
-- --
-- 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- --
----------------------
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
-- --
-- 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- --
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
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
-- 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;
-- --
-- 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- --
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
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;
-- 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
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
-- 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
"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);
-- 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);
-- --
-- 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- --
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;
projects / gcc.git / commitdiff