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

[multiple changes] 

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

	* einfo.adb (Derived_Type_Link): New function
	(Set_Derived_Type_Link): New procedure.
	(Write_Field31_Name): Output Derived_Type_Link.
	* einfo.ads: New field Derived_Type_Link.
	* exp_ch6.adb (Expand_Call): Warn if change of representation
	needed on call.
	* sem_ch13.adb: Minor addition of ??? comment.
	(Rep_Item_Too_Late): Warn on case that is legal but could cause an
	expensive implicit conversion.
	* sem_ch3.adb (Build_Derived_Type): Set Derived_Type_Link if needed.

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

	* exp_ch3.adb (Build_Init_Procedure): Renamed Local_DF_Id
	to DF_Id. Add new local variable DF_Call. Do not perform any
	elaboration-related checks on the call to the partial finalization
	routine within an init proc to avoid generating bogus elaboration
	warnings on expansion-related code.
	* sem_elab.adb (Check_A_Call): Move constant Access_Case to
	the top level of the routine.  Ensure that Output_Calls takes
	into account flags -gnatel and -gnatwl when emitting warnings
	or info messages.
	(Check_Internal_Call_Continue): Update the call to Output_Calls.
	(Elab_Warning): Moved to the top level of routine Check_A_Call.
	(Emit): New routines.
	(Output_Calls): Add new formal parameter Check_Elab_Flag along with a
	comment on usage. Output all warnings or info messages only when the
	caller context demands it and the proper elaboration flag is set.

2014-07-29  Yannick Moy  <moy@adacore.com>

	* sem_attr.adb (Analyze_Attribute/Attribute_Old):
	Check rule about Old appearing in potentially unevaluated
	expression everywhere, not only in Post.

2014-07-29  Arnaud Charlet  <charlet@adacore.com>

	* sem_prag.adb: Update comment.
	* a-except.adb, a-except-2005.adb: Minor editing.

2014-07-29  Pierre-Marie Derodat  <derodat@adacore.com>

	* exp_dbug.adb (Debug_Renaming_Declaration):
	Do not create renaming entities for renamings of non-packed
	objects and for exceptions.

From-SVN: r213175
This commit is contained in:
Arnaud Charlet 2014-07-29 15:30:02 +02:00
parent a8b346d2eb
commit ab01e61483
13 changed files with 394 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
gcc/ada/ChangeLog
View File

@ -1,3 +1,51 @@
2014-07-29 Robert Dewar <dewar@adacore.com>
* einfo.adb (Derived_Type_Link): New function
(Set_Derived_Type_Link): New procedure.
(Write_Field31_Name): Output Derived_Type_Link.
* einfo.ads: New field Derived_Type_Link.
* exp_ch6.adb (Expand_Call): Warn if change of representation
needed on call.
* sem_ch13.adb: Minor addition of ??? comment.
(Rep_Item_Too_Late): Warn on case that is legal but could cause an
expensive implicit conversion.
* sem_ch3.adb (Build_Derived_Type): Set Derived_Type_Link if needed.
2014-07-29 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb (Build_Init_Procedure): Renamed Local_DF_Id
to DF_Id. Add new local variable DF_Call. Do not perform any
elaboration-related checks on the call to the partial finalization
routine within an init proc to avoid generating bogus elaboration
warnings on expansion-related code.
* sem_elab.adb (Check_A_Call): Move constant Access_Case to
the top level of the routine. Ensure that Output_Calls takes
into account flags -gnatel and -gnatwl when emitting warnings
or info messages.
(Check_Internal_Call_Continue): Update the call to Output_Calls.
(Elab_Warning): Moved to the top level of routine Check_A_Call.
(Emit): New routines.
(Output_Calls): Add new formal parameter Check_Elab_Flag along with a
comment on usage. Output all warnings or info messages only when the
caller context demands it and the proper elaboration flag is set.
2014-07-29 Yannick Moy <moy@adacore.com>
* sem_attr.adb (Analyze_Attribute/Attribute_Old):
Check rule about Old appearing in potentially unevaluated
expression everywhere, not only in Post.
2014-07-29 Arnaud Charlet <charlet@adacore.com>
* sem_prag.adb: Update comment.
* a-except.adb, a-except-2005.adb: Minor editing.
2014-07-29 Pierre-Marie Derodat <derodat@adacore.com>
* exp_dbug.adb (Debug_Renaming_Declaration):
Do not create renaming entities for renamings of non-packed
objects and for exceptions.
2014-07-29 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sinfo.ads, types.ads, sem_prag.adb, a-except-2005.adb,

11
gcc/ada/a-except-2005.adb
View File

@ -404,17 +404,6 @@ package body Ada.Exceptions is
-- attached. The parameters are the file name and line number in each
-- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
-- Note on ordering of these routines. Normally in the Ada.Exceptions units
-- we don't care about the ordering of entries for Rcheck routines, and
-- the normal approach is to keep them in the same order as declarations
-- in Types.
-- This section is an IMPORTANT EXCEPTION. It is essential that the
-- routines in this section be declared in the same order as the Rmsg_xx
-- constants in the following section. This is required by the .Net runtime
-- which uses the exceptmsg.awk script to generate require exception data,
-- and this script requires and expects that this ordering rule holds.
procedure Rcheck_CE_Access_Check
(File : System.Address; Line : Integer);
procedure Rcheck_CE_Null_Access_Parameter

15
gcc/ada/a-except.adb
View File

@ -360,6 +360,17 @@ package body Ada.Exceptions is
-- attached. The parameters are the file name and line number in each
-- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
-- Note on ordering of these routines. Normally in the Ada.Exceptions units
-- we don't care about the ordering of entries for Rcheck routines, and
-- the normal approach is to keep them in the same order as declarations
-- in Types.
-- This section is an IMPORTANT EXCEPTION. It is essential that the
-- routines in this section be declared in the same order as the Rmsg_xx
-- constants in the following section. This is required by the .Net runtime
-- which uses the exceptmsg.awk script to generate require exception data,
-- and this script requires and expects that this ordering rule holds.
procedure Rcheck_CE_Access_Check
(File : System.Address; Line : Integer);
procedure Rcheck_CE_Null_Access_Parameter
@ -418,8 +429,6 @@ package body Ada.Exceptions is
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Potentially_Blocking_Operation
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Stream_Operation_Not_Allowed
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Unchecked_Union_Restriction
@ -432,6 +441,8 @@ package body Ada.Exceptions is
(File : System.Address; Line : Integer);
procedure Rcheck_SE_Object_Too_Large
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Stream_Operation_Not_Allowed
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Finalize_Raised_Exception
(File : System.Address; Line : Integer);

16
gcc/ada/einfo.adb
View File

@ -249,6 +249,7 @@ package body Einfo is
-- Last_Aggregate_Assignment Node30
-- Static_Initialization Node30
-- Derived_Type_Link Node31
-- Thunk_Entity Node31
-- SPARK_Pragma Node32
@ -949,6 +950,12 @@ package body Einfo is
return Flag14 (Id);
end Depends_On_Private;
function Derived_Type_Link (Id : E) return E is
begin
pragma Assert (Is_Type (Id));
return Node31 (Base_Type (Id));
end Derived_Type_Link;
function Digits_Value (Id : E) return U is
begin
pragma Assert
@ -3682,6 +3689,12 @@ package body Einfo is
Set_Flag14 (Id, V);
end Set_Depends_On_Private;
procedure Set_Derived_Type_Link (Id : E; V : E) is
begin
pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Node31 (Id, V);
end Set_Derived_Type_Link;
procedure Set_Digits_Value (Id : E; V : U) is
begin
pragma Assert
@ -9596,6 +9609,9 @@ package body Einfo is
E_Function =>
Write_Str ("Thunk_Entity");
when Type_Kind =>
Write_Str ("Derived_Type_Link");
when others =>
Write_Str ("Field31??");
end case;

27
gcc/ada/einfo.ads
View File

@ -819,6 +819,28 @@ package Einfo is
-- Defined in all type entities. Set if the type is private or if it
-- depends on a private type.
-- Derived_Type_Link (Node31)
-- Defined in all type and subtype entries. Set in a base type if
-- a derived type declaration is encountered which derives from
-- this base type or one of its subtypes, and there are already
-- primitive operations declared. In this case, it references the
-- entity for the type declared by the derived type declaration.
-- For example:
--
-- type R is ...
-- subtype RS is R ...
-- ...
-- type G is new RS ...
--
-- In this case, if primitive operations have been declared for R, at
-- the point of declaration of G, then the Derived_Type_Link of R is set
-- to point to the entity for G. This is used to generate warnings for
-- rep clauses that appear later on for R, which might result in an
-- unexpected implicit conversion operation.
--
-- Note: if there is more than one such derived type, the link will point
-- to the last one (this is only used in generating warning messages).
-- Designated_Type (synthesized)
-- Applies to access types. Returns the designated type. Differs from
-- Directly_Designated_Type in that if the access type refers to an
@ -5199,6 +5221,7 @@ package Einfo is
-- Related_Expression (Node24)
-- Current_Use_Clause (Node27)
-- Subprograms_For_Type (Node29)
-- Derived_Type_Link (Node31)
-- Linker_Section_Pragma (Node33)
-- Depends_On_Private (Flag14)
@ -6461,6 +6484,7 @@ package Einfo is
function Delta_Value (Id : E) return R;
function Dependent_Instances (Id : E) return L;
function Depends_On_Private (Id : E) return B;
function Derived_Type_Link (Id : E) return E;
function Digits_Value (Id : E) return U;
function Direct_Primitive_Operations (Id : E) return L;
function Directly_Designated_Type (Id : E) return E;
@ -7095,6 +7119,7 @@ package Einfo is
procedure Set_Delta_Value (Id : E; V : R);
procedure Set_Dependent_Instances (Id : E; V : L);
procedure Set_Depends_On_Private (Id : E; V : B := True);
procedure Set_Derived_Type_Link (Id : E; V : E);
procedure Set_Digits_Value (Id : E; V : U);
procedure Set_Direct_Primitive_Operations (Id : E; V : L);
procedure Set_Directly_Designated_Type (Id : E; V : E);
@ -7841,6 +7866,7 @@ package Einfo is
pragma Inline (Delta_Value);
pragma Inline (Dependent_Instances);
pragma Inline (Depends_On_Private);
pragma Inline (Derived_Type_Link);
pragma Inline (Digits_Value);
pragma Inline (Direct_Primitive_Operations);
pragma Inline (Directly_Designated_Type);
@ -8322,6 +8348,7 @@ package Einfo is
pragma Inline (Set_Delta_Value);
pragma Inline (Set_Dependent_Instances);
pragma Inline (Set_Depends_On_Private);
pragma Inline (Set_Derived_Type_Link);
pragma Inline (Set_Digits_Value);
pragma Inline (Set_Direct_Primitive_Operations);
pragma Inline (Set_Directly_Designated_Type);

34
gcc/ada/exp_ch3.adb
View File

@ -2596,7 +2596,7 @@ package body Exp_Ch3 is
Set_Statements (Handled_Stmt_Node, Body_Stmts);
-- Generate:
-- Local_DF_Id (_init, C1, ..., CN);
-- Deep_Finalize (_init, C1, ..., CN);
-- raise;
if Counter > 0
@ -2605,30 +2605,36 @@ package body Exp_Ch3 is
and then not Restriction_Active (No_Exception_Propagation)
then
declare
Local_DF_Id : Entity_Id;
DF_Call : Node_Id;
DF_Id : Entity_Id;
begin
-- Create a local version of Deep_Finalize which has indication
-- of partial initialization state.
Local_DF_Id := Make_Temporary (Loc, 'F');
DF_Id := Make_Temporary (Loc, 'F');
Append_To (Decls,
Make_Local_Deep_Finalize (Rec_Type, Local_DF_Id));
Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
DF_Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (DF_Id, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_uInit),
New_Occurrence_Of (Standard_False, Loc)));
-- Do not emit warnings related to the elaboration order when a
-- controlled object is declared before the body of Finalize is
-- seen.
Set_No_Elaboration_Check (DF_Call);
Set_Exception_Handlers (Handled_Stmt_Node, New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Local_DF_Id, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_uInit),
New_Occurrence_Of (Standard_False, Loc))),
Statements => New_List (
DF_Call,
Make_Raise_Statement (Loc)))));
end;
else

16
gcc/ada/exp_ch6.adb
View File

@ -3705,19 +3705,27 @@ package body Exp_Ch6 is
Resolve (Actual, Parent_Typ);
end if;
-- If there is a change of representation, then generate a
-- warning, and do the change of representation.
elsif not Same_Representation (Formal_Typ, Parent_Typ) then
Error_Msg_N
("??change of representation required", Actual);
Convert (Actual, Parent_Typ);
-- For array and record types, the parent formal type and
-- derived formal type have different sizes or pragma Pack
-- status.
elsif ((Is_Array_Type (Formal_Typ)
and then Is_Array_Type (Parent_Typ))
and then Is_Array_Type (Parent_Typ))
or else
(Is_Record_Type (Formal_Typ)
and then Is_Record_Type (Parent_Typ)))
and then Is_Record_Type (Parent_Typ)))
and then
(Esize (Formal_Typ) /= Esize (Parent_Typ)
or else Has_Pragma_Pack (Formal_Typ) /=
Has_Pragma_Pack (Parent_Typ))
or else Has_Pragma_Pack (Formal_Typ) /=
Has_Pragma_Pack (Parent_Typ))
then
Convert (Actual, Parent_Typ);
end if;

36
gcc/ada/exp_dbug.adb
View File

@ -306,6 +306,16 @@ package body Exp_Dbug is
Obj : Entity_Id;
Res : Node_Id;
Enable : Boolean := Nkind (N) = N_Package_Renaming_Declaration;
-- By default, we do not generate an encoding for renaming. This is
-- however done (in which case this is set to True) in a few cases:
-- - when a package is renamed,
-- - when the renaming involves a packed array,
-- - when the renaming involves a packed record.
procedure Enable_If_Packed_Array (N : Node_Id);
-- Enable encoding generation if N is a packed array
function Output_Subscript (N : Node_Id; S : String) return Boolean;
-- Outputs a single subscript value as ?nnn (subscript is compile time
-- known value with value nnn) or as ?e (subscript is local constant
@ -314,6 +324,21 @@ package body Exp_Dbug is
-- output in one of these two forms. The result is prepended to the
-- name stored in Name_Buffer.
----------------------------
-- Enable_If_Packed_Array --
----------------------------
procedure Enable_If_Packed_Array (N : Node_Id) is
T : constant Entity_Id := Etype (N);
begin
Enable :=
(Enable
or else
(Ekind (T) in Array_Kind
and then
Present (Packed_Array_Impl_Type (T))));
end Enable_If_Packed_Array;
----------------------
-- Output_Subscript --
----------------------
@ -372,6 +397,8 @@ package body Exp_Dbug is
exit;
when N_Selected_Component =>
Enable :=
Enable or else Is_Packed (Etype (Prefix (Ren)));
Prepend_String_To_Buffer
(Get_Name_String (Chars (Selector_Name (Ren))));
Prepend_String_To_Buffer ("XR");
@ -382,6 +409,7 @@ package body Exp_Dbug is
X : Node_Id := Last (Expressions (Ren));
begin
Enable_If_Packed_Array (Prefix (Ren));
while Present (X) loop
if not Output_Subscript (X, "XS") then
Set_Materialize_Entity (Ent);
@ -396,6 +424,7 @@ package body Exp_Dbug is
when N_Slice =>
Enable_If_Packed_Array (Prefix (Ren));
Typ := Etype (First_Index (Etype (Nam)));
if not Output_Subscript (Type_High_Bound (Typ), "XS") then
@ -422,6 +451,13 @@ package body Exp_Dbug is
end case;
end loop;
-- If we found no reason here to emit an encoding, stop now.
if not Enable then
Set_Materialize_Entity (Ent);
return Empty;
end if;
Prepend_String_To_Buffer ("___XE");
-- Include the designation of the form of renaming

27
gcc/ada/sem_attr.adb
View File

@ -4564,25 +4564,11 @@ package body Sem_Attr is
-- Ensure that the obtained expression is the consequence of a
-- contract case as this is the only postcondition-like part of
-- the pragma.
-- the pragma. Otherwise, attribute 'Old appears in the condition
-- of a contract case. Emit an error since this is not a
-- postcondition-like context. (SPARK RM 6.1.3(2))
if Expr = Expression (Parent (Expr)) then
-- Warn that a potentially unevaluated prefix is always
-- evaluated when the corresponding consequence is selected.
if Is_Potentially_Unevaluated (P) then
Error_Msg_Name_1 := Aname;
Error_Msg_N
("??prefix of attribute % is always evaluated when "
& "related consequence is selected", P);
end if;
-- Attribute 'Old appears in the condition of a contract case.
-- Emit an error since this is not a postcondition-like context.
-- (SPARK RM 6.1.3(2))
else
if Expr /= Expression (Parent (Expr)) then
Error_Attr
("attribute % cannot appear in the condition "
& "of a contract case", P);
@ -4773,11 +4759,10 @@ package body Sem_Attr is
("??attribute Old applied to constant has no effect", P);
end if;
-- Check that the prefix of 'Old is an entity, when it appears in
-- a postcondition and may be potentially unevaluated (6.1.1 (27/3)).
-- Check that the prefix of 'Old is an entity when it may be
-- potentially unevaluated (6.1.1 (27/3)).
if Present (Prag)
and then Get_Pragma_Id (Prag) = Pragma_Postcondition
and then Is_Potentially_Unevaluated (N)
and then not Is_Entity_Name (P)
then

67
gcc/ada/sem_ch13.adb
View File

@ -11074,6 +11074,9 @@ package body Sem_Ch13 is
-- Note that neither of the above errors is considered a serious one,
-- since the effect is simply that we ignore the representation clause
-- in these cases.
-- Is this really true? In any case if we make this change we must
-- document the requirement in the spec of Rep_Item_Too_Late that
-- if True is returned, then the rep item must be completely ignored???
----------------------
-- No_Type_Rep_Item --
@ -11122,8 +11125,10 @@ package body Sem_Ch13 is
S := First_Subtype (T);
if Present (Freeze_Node (S)) then
Error_Msg_NE
("??no more representation items for }", Freeze_Node (S), S);
if not Relaxed_RM_Semantics then
Error_Msg_NE
("??no more representation items for }", Freeze_Node (S), S);
end if;
end if;
return True;
@ -11142,18 +11147,68 @@ package body Sem_Ch13 is
if Has_Primitive_Operations (Parent_Type) then
No_Type_Rep_Item;
Error_Msg_NE
("\parent type & has primitive operations!", N, Parent_Type);
if not Relaxed_RM_Semantics then
Error_Msg_NE
("\parent type & has primitive operations!", N, Parent_Type);
end if;
return True;
elsif Is_By_Reference_Type (Parent_Type) then
No_Type_Rep_Item;
Error_Msg_NE
("\parent type & is a by reference type!", N, Parent_Type);
if not Relaxed_RM_Semantics then
Error_Msg_NE
("\parent type & is a by reference type!", N, Parent_Type);
end if;
return True;
end if;
end if;
-- No error, but one more warning to consider. The RM (surprisingly)
-- allows this pattern:
-- type S is ...
-- primitive operations for S
-- type R is new S;
-- rep clause for S
-- Meaning that calls on the primitive operations of S for values of
-- type R may require possibly expensive implicit conversion operations.
-- This is not an error, but is worth a warning.
if not Relaxed_RM_Semantics and then Is_Type (T) then
declare
DTL : constant Entity_Id := Derived_Type_Link (Base_Type (T));
begin
if Present (DTL)
and then Has_Primitive_Operations (Base_Type (T))
-- For now, do not generate this warning for the case of aspect
-- specification using Ada 2012 syntax, since we get wrong
-- messages we do not understand. The whole business of derived
-- types and rep items seems a bit confused when aspects are
-- used, since the aspects are not evaluated till freeze time.
and then not From_Aspect_Specification (N)
then
Error_Msg_Sloc := Sloc (DTL);
Error_Msg_N
("representation item for& appears after derived type "
& "declaration#??", N);
Error_Msg_NE
("\may result in implicit conversions for primitive "
& "operations of&??", N, T);
Error_Msg_NE
("\to change representations when called with arguments "
& "of type&??", N, DTL);
end if;
end;
end if;
-- No error, link item into head of chain of rep items for the entity,
-- but avoid chaining if we have an overloadable entity, and the pragma
-- is one that can apply to multiple overloaded entities.

6
gcc/ada/sem_ch3.adb
View File

@ -8503,6 +8503,12 @@ package body Sem_Ch3 is
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
-- If the parent has primitive routines, set the derived type link
if Has_Primitive_Operations (Parent_Type) then
Set_Derived_Type_Link (Parent_Base, Derived_Type);
end if;
-- If the parent type is a private subtype, the convention on the base
-- type may be set in the private part, and not propagated to the
-- subtype until later, so we obtain the convention from the base type.

253
gcc/ada/sem_elab.adb
View File

@ -263,11 +263,15 @@ package body Sem_Elab is
function Is_Finalization_Procedure (Id : Entity_Id) return Boolean;
-- Determine whether entity Id denotes a [Deep_]Finalize procedure
procedure Output_Calls (N : Node_Id);
procedure Output_Calls
(N : Node_Id;
Check_Elab_Flag : Boolean);
-- Outputs chain of calls stored in the Elab_Call table. The caller has
-- already generated the main warning message, so the warnings generated
-- are all continuation messages. The argument is the call node at which
-- the messages are to be placed.
-- the messages are to be placed. When Check_Elab_Flag is set, calls are
-- enumerated only when flag Elab_Warning is set for the dynamic case or
-- when flag Elab_Info_Messages is set for the statis case.
function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
-- Given two scopes, determine whether they are the same scope from an
@ -497,6 +501,48 @@ package body Sem_Elab is
Generate_Warnings : Boolean := True;
In_Init_Proc : Boolean := False)
is
Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
-- Indicates if we have Access attribute case
procedure Elab_Warning
(Msg_D : String;
Msg_S : String;
Ent : Node_Or_Entity_Id);
-- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
-- dynamic or static elaboration model), N and Ent. Msg_D is a real
-- warning (output if Msg_D is non-null and Elab_Warnings is set),
-- Msg_S is an info message (output if Elab_Info_Messages is set.
------------------
-- Elab_Warning --
------------------
procedure Elab_Warning
(Msg_D : String;
Msg_S : String;
Ent : Node_Or_Entity_Id)
is
begin
-- Dynamic elaboration checks, real warning
if Dynamic_Elaboration_Checks then
if not Access_Case then
if Msg_D /= "" and then Elab_Warnings then
Error_Msg_NE (Msg_D, N, Ent);
end if;
end if;
-- Static elaboration checks, info message
else
if Elab_Info_Messages then
Error_Msg_NE (Msg_S, N, Ent);
end if;
end if;
end Elab_Warning;
-- Local variables
Loc : constant Source_Ptr := Sloc (N);
Ent : Entity_Id;
Decl : Node_Id;
@ -525,9 +571,6 @@ package body Sem_Elab is
Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
-- Indicates if we have instantiation case
Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
-- Indicates if we have Access attribute case
Caller_Unit_Internal : Boolean;
Callee_Unit_Internal : Boolean;
@ -544,6 +587,8 @@ package body Sem_Elab is
-- warnings on the scope are also suppressed. For the internal case,
-- we ignore this flag.
-- Start of processing for Check_A_Call
begin
-- If the call is known to be within a local Suppress Elaboration
-- pragma, nothing to check. This can happen in task bodies. But
@ -873,101 +918,64 @@ package body Sem_Elab is
and then (Elab_Warnings or Elab_Info_Messages)
and then Generate_Warnings
then
Generate_Elab_Warnings : declare
procedure Elab_Warning
(Msg_D : String;
Msg_S : String;
Ent : Node_Or_Entity_Id);
-- Generate a call to Error_Msg_NE with parameters Msg_D or
-- Msg_S (for dynamic or static elaboration model), N and Ent.
-- Msg_D is a real warning (output if Msg_D is non-null and
-- Elab_Warnings is set), Msg_S is an info message (output if
-- Elab_Info_Messages is set.
-- Instantiation case
------------------
-- Elab_Warning --
------------------
if Inst_Case then
Elab_Warning
("instantiation of& may raise Program_Error?l?",
"info: instantiation of& during elaboration?$?", Ent);
procedure Elab_Warning
(Msg_D : String;
Msg_S : String;
Ent : Node_Or_Entity_Id)
is
begin
-- Dynamic elaboration checks, real warning
-- Indirect call case, info message only in static elaboration
-- case, because the attribute reference itself cannot raise an
-- exception.
if Dynamic_Elaboration_Checks then
if not Access_Case then
if Msg_D /= "" and then Elab_Warnings then
Error_Msg_NE (Msg_D, N, Ent);
end if;
end if;
elsif Access_Case then
Elab_Warning
("", "info: access to& during elaboration?$?", Ent);
-- Static elaboration checks, info message
-- Subprogram call case
else
if Elab_Info_Messages then
Error_Msg_NE (Msg_S, N, Ent);
end if;
end if;
end Elab_Warning;
-- Start of processing for Generate_Elab_Warnings
begin
-- Instantiation case
if Inst_Case then
else
if Nkind (Name (N)) in N_Has_Entity
and then Is_Init_Proc (Entity (Name (N)))
and then Comes_From_Source (Ent)
then
Elab_Warning
("instantiation of& may raise Program_Error?l?",
"info: instantiation of& during elaboration?$?", Ent);
-- Indirect call case, info message only in static elaboration
-- case, because the attribute reference itself cannot raise
-- an exception.
elsif Access_Case then
Elab_Warning
("", "info: access to& during elaboration?$?", Ent);
-- Subprogram call case
else
if Nkind (Name (N)) in N_Has_Entity
and then Is_Init_Proc (Entity (Name (N)))
and then Comes_From_Source (Ent)
then
Elab_Warning
("implicit call to & may raise Program_Error?l?",
"info: implicit call to & during elaboration?$?",
Ent);
else
Elab_Warning
("call to & may raise Program_Error?l?",
"info: call to & during elaboration?$?",
Ent);
end if;
end if;
Error_Msg_Qual_Level := Nat'Last;
if Nkind (N) in N_Subprogram_Instantiation then
Elab_Warning
("\missing pragma Elaborate for&?l?",
"\implicit pragma Elaborate for& generated?$?",
W_Scope);
("implicit call to & may raise Program_Error?l?",
"info: implicit call to & during elaboration?$?",
Ent);
else
Elab_Warning
("\missing pragma Elaborate_All for&?l?",
"\implicit pragma Elaborate_All for & generated?$?",
W_Scope);
("call to & may raise Program_Error?l?",
"info: call to & during elaboration?$?",
Ent);
end if;
end Generate_Elab_Warnings;
end if;
Error_Msg_Qual_Level := Nat'Last;
if Nkind (N) in N_Subprogram_Instantiation then
Elab_Warning
("\missing pragma Elaborate for&?l?",
"\implicit pragma Elaborate for& generated?$?",
W_Scope);
else
Elab_Warning
("\missing pragma Elaborate_All for&?l?",
"\implicit pragma Elaborate_All for & generated?$?",
W_Scope);
end if;
Error_Msg_Qual_Level := 0;
Output_Calls (N);
-- Take into account the flags related to elaboration warning
-- messages when enumerating the various calls involved. This
-- ensures the proper pairing of the main warning and the
-- clarification messages generated by Output_Calls.
Output_Calls (N, Check_Elab_Flag => True);
-- Set flag to prevent further warnings for same unit unless in
-- All_Errors_Mode.
@ -2316,7 +2324,12 @@ package body Sem_Elab is
Error_Msg_N ("\Program_Error ]<l<", N);
Output_Calls (N);
-- There is no need to query the elaboration warning message flags
-- because the main message is an error, not a warning, therefore
-- all the clarification messages produces by Output_Calls must be
-- emitted unconditionally.
Output_Calls (N, Check_Elab_Flag => False);
end if;
end if;
@ -3053,8 +3066,13 @@ package body Sem_Elab is
-- Output_Calls --
------------------
procedure Output_Calls (N : Node_Id) is
Ent : Entity_Id;
procedure Output_Calls
(N : Node_Id;
Check_Elab_Flag : Boolean)
is
function Emit (Flag : Boolean) return Boolean;
-- Determine whether to emit an error message based on the combination
-- of flags Check_Elab_Flag and Flag.
function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
-- An internal function, used to determine if a name, Nm, is either
@ -3062,6 +3080,19 @@ package body Sem_Elab is
-- by the error message circuits (i.e. it has a single upper
-- case letter at the end).
----------
-- Emit --
----------
function Emit (Flag : Boolean) return Boolean is
begin
if Check_Elab_Flag then
return Flag;
else
return True;
end if;
end Emit;
-----------------------------
-- Is_Printable_Error_Name --
-----------------------------
@ -3080,6 +3111,10 @@ package body Sem_Elab is
end if;
end Is_Printable_Error_Name;
-- Local variables
Ent : Entity_Id;
-- Start of processing for Output_Calls
begin
@ -3091,27 +3126,31 @@ package body Sem_Elab is
-- Dynamic elaboration model, warnings controlled by -gnatwl
if Dynamic_Elaboration_Checks then
if Is_Generic_Unit (Ent) then
Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\\?l?initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
Error_Msg_NE ("\\?l?& called #", N, Ent);
else
Error_Msg_N ("\\?l?called #", N);
if Emit (Elab_Warnings) then
if Is_Generic_Unit (Ent) then
Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\\?l?initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
Error_Msg_NE ("\\?l?& called #", N, Ent);
else
Error_Msg_N ("\\?l?called #", N);
end if;
end if;
-- Static elaboration model, info messages controlled by -gnatel
else
if Is_Generic_Unit (Ent) then
Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\\?$?initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
Error_Msg_NE ("\\?$?& called #", N, Ent);
else
Error_Msg_N ("\\?$?called #", N);
if Emit (Elab_Info_Messages) then
if Is_Generic_Unit (Ent) then
Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\\?$?initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
Error_Msg_NE ("\\?$?& called #", N, Ent);
else
Error_Msg_N ("\\?$?called #", N);
end if;
end if;
end if;
end loop;

4
gcc/ada/sem_prag.adb
View File

@ -11022,7 +11022,9 @@ package body Sem_Prag is
-- If Allow_Integer_Address is already set do nothing, otherwise
-- calling RTE on RE_Address would cause a crash when loading
-- system.ads.
-- system.ads. ??? same will happen if Allow_Integer_Address is
-- not set actually, to be fixed and then the guard on
-- not Opt.Allow_Integer_Address should be removed.
if not Opt.Allow_Integer_Address
and then Is_Private_Type (RTE (RE_Address))