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,
sem_ch6.adb, par-ch3.adb: Minor reformatting.
-- 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
-- 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
(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
(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);
-- Last_Aggregate_Assignment Node30
-- Static_Initialization Node30
+ -- Derived_Type_Link Node31
-- Thunk_Entity Node31
-- SPARK_Pragma Node32
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
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
E_Function =>
Write_Str ("Thunk_Entity");
+ when Type_Kind =>
+ Write_Str ("Derived_Type_Link");
+
when others =>
Write_Str ("Field31??");
end case;
-- 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
-- Related_Expression (Node24)
-- Current_Use_Clause (Node27)
-- Subprograms_For_Type (Node29)
+ -- Derived_Type_Link (Node31)
-- Linker_Section_Pragma (Node33)
-- Depends_On_Private (Flag14)
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;
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);
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);
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);
Set_Statements (Handled_Stmt_Node, Body_Stmts);
-- Generate:
- -- Local_DF_Id (_init, C1, ..., CN);
+ -- Deep_Finalize (_init, C1, ..., CN);
-- raise;
if Counter > 0
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
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;
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
-- 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 --
----------------------
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");
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);
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
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
-- 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);
("??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
-- 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 --
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;
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.
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.
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
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;
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;
-- 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
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.
-
- ------------------
- -- 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;
+ -- Instantiation case
- -- 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;
-
- -- Start of processing for Generate_Elab_Warnings
+ if Inst_Case then
+ Elab_Warning
+ ("instantiation of& may raise Program_Error?l?",
+ "info: instantiation of& during elaboration?$?", Ent);
- begin
- -- Instantiation case
+ -- Indirect call case, info message only in static elaboration
+ -- case, because the attribute reference itself cannot raise an
+ -- exception.
- if Inst_Case then
- Elab_Warning
- ("instantiation of& may raise Program_Error?l?",
- "info: instantiation of& during elaboration?$?", Ent);
+ elsif Access_Case then
+ Elab_Warning
+ ("", "info: access to& during elaboration?$?", Ent);
- -- Indirect call case, info message only in static elaboration
- -- case, because the attribute reference itself cannot raise
- -- an exception.
+ -- Subprogram call case
- elsif Access_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
- ("", "info: access to& during elaboration?$?", Ent);
-
- -- Subprogram call case
+ ("implicit call to & may raise Program_Error?l?",
+ "info: implicit call to & during elaboration?$?",
+ Ent);
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;
+ 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;
+ 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);
+ 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;
- end Generate_Elab_Warnings;
+ 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.
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;
-- 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
-- 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 --
-----------------------------
end if;
end Is_Printable_Error_Name;
+ -- Local variables
+
+ Ent : Entity_Id;
+
-- Start of processing for Output_Calls
begin
-- 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;
-- 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))
projects / platform / upstream / linaro-gcc.git / commitdiff