FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2014-05-21  Robert Dewar  <dewar@adacore.com>

	* sem_elab.adb: Minor reformatting.
	* s-taprop.ads: Minor comment fix.
	* sem_ch8.adb (Analyze_Subprogram_Renaming): Remove call to
	Kill_Elaboration_Checks.
	* errout.adb, erroutc.adb: Minor reformatting.

2014-05-21  Thomas Quinot  <quinot@adacore.com>

	* exp_pakd.adb (Byte_Swap): Handle the case of a sub-byte
	component. No byte swapping occurs, but this procedure also takes
	care of appropriately justifying the argument.

2014-05-21  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch6.adb: sem_ch6.adb (Analyze_Aspects_On_Body_Or_Stub):
	New routine.
	(Analyze_Subprogram_Body_Helper): Move the
	analysis of aspect specifications and the processing of the
	subprogram body contract after inlining has taken place.
	(Diagnose_Misplaced_Aspect_Specifications): Removed.

2014-05-21  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): Revert previous change.

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* sem_eval.ads, sem_eval.adb (Why_Not_Static): Messages are not
	continuations any more.

2014-05-21  Ed Schonberg  <schonberg@adacore.com>

	* sinfo.ads, sinfo.adb: New flag Needs_Initialized_Actual,
	present in formal_Private_Definitions and on private extension
	declarations of a formal derived type. Set when the use of the
	formal type in a generic suggests that the actual should be a
	fully initialized type.
	* sem_warn.adb (May_Need_Initialized_Actual): new subprogram
	to indicate that an entity of a generic type has default
	initialization, and that the corresponing actual type in any
	subsequent instantiation should be fully initialized.
	* sem_ch12.adb (Check_Initialized_Type): new subprogram,
	to emit a warning if the actual for a generic type on which
	Needs_Initialized_Actual is set is not a fully initialized type.

From-SVN: r210705
This commit is contained in:
Arnaud Charlet 2014-05-21 15:14:06 +02:00
parent 23e28b4217
commit c8a3028c36
15 changed files with 505 additions and 340 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
gcc/ada/ChangeLog
View file

@ -1,3 +1,50 @@
2014-05-21 Robert Dewar <dewar@adacore.com>
* sem_elab.adb: Minor reformatting.
* s-taprop.ads: Minor comment fix.
* sem_ch8.adb (Analyze_Subprogram_Renaming): Remove call to
Kill_Elaboration_Checks.
* errout.adb, erroutc.adb: Minor reformatting.
2014-05-21 Thomas Quinot <quinot@adacore.com>
* exp_pakd.adb (Byte_Swap): Handle the case of a sub-byte
component. No byte swapping occurs, but this procedure also takes
care of appropriately justifying the argument.
2014-05-21 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch6.adb: sem_ch6.adb (Analyze_Aspects_On_Body_Or_Stub):
New routine.
(Analyze_Subprogram_Body_Helper): Move the
analysis of aspect specifications and the processing of the
subprogram body contract after inlining has taken place.
(Diagnose_Misplaced_Aspect_Specifications): Removed.
2014-05-21 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Build_Derived_Record_Type): Revert previous change.
2014-05-21 Robert Dewar <dewar@adacore.com>
* sem_eval.ads, sem_eval.adb (Why_Not_Static): Messages are not
continuations any more.
2014-05-21 Ed Schonberg <schonberg@adacore.com>
* sinfo.ads, sinfo.adb: New flag Needs_Initialized_Actual,
present in formal_Private_Definitions and on private extension
declarations of a formal derived type. Set when the use of the
formal type in a generic suggests that the actual should be a
fully initialized type.
* sem_warn.adb (May_Need_Initialized_Actual): new subprogram
to indicate that an entity of a generic type has default
initialization, and that the corresponing actual type in any
subsequent instantiation should be fully initialized.
* sem_ch12.adb (Check_Initialized_Type): new subprogram,
to emit a warning if the actual for a generic type on which
Needs_Initialized_Actual is set is not a fully initialized type.
2014-05-21 Robert Dewar <dewar@adacore.com>
* sem_elab.adb, prj-dect.adb: Minor reformatting.

9
gcc/ada/errout.adb
View file

@ -1010,14 +1010,11 @@ package body Errout is
exit when
Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
if Errors.Table (Cur_Msg).Sfile =
Errors.Table (Next_Msg).Sfile
if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
then
exit when Sptr < Errors.Table (Next_Msg).Sptr
or else
(Sptr = Errors.Table (Next_Msg).Sptr
and then
Optr < Errors.Table (Next_Msg).Optr);
or else (Sptr = Errors.Table (Next_Msg).Sptr
and then Optr < Errors.Table (Next_Msg).Optr);
end if;
Prev_Msg := Next_Msg;

14
gcc/ada/erroutc.adb
View file

@ -113,13 +113,13 @@ package body Erroutc is
N1, N2 : Error_Msg_Id;
procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
-- Called to delete message Delete, keeping message Keep. Marks all
-- messages of Delete with deleted flag set to True, and also makes sure
-- that for the error messages that are retained the preferred message
-- is the one retained (we prefer the shorter one in the case where one
-- has an Instance tag). Note that we always know that Keep has at least
-- as many continuations as Delete (since we always delete the shorter
-- sequence).
-- Called to delete message Delete, keeping message Keep. Marks msg
-- Delete and all its continuations with deleted flag set to True.
-- Also makes sure that for the error messages that are retained the
-- preferred message is the one retained (we prefer the shorter one in
-- the case where one has an Instance tag). Note that we always know
-- that Keep has at least as many continuations as Delete (since we
-- always delete the shorter sequence).
----------------
-- Delete_Msg --

36
gcc/ada/exp_pakd.adb
View file

@ -576,20 +576,26 @@ package body Exp_Pakd is
Shift : Uint;
begin
pragma Assert (T_Size > 8);
if T_Size <= 8 then
Swap_F := Empty;
Swap_T := RTE (RE_Unsigned_8);
if T_Size <= 16 then
Swap_RE := RE_Bswap_16;
else
if T_Size <= 16 then
Swap_RE := RE_Bswap_16;
elsif T_Size <= 32 then
Swap_RE := RE_Bswap_32;
elsif T_Size <= 32 then
Swap_RE := RE_Bswap_32;
else pragma Assert (T_Size <= 64);
Swap_RE := RE_Bswap_64;
end if;
Swap_F := RTE (Swap_RE);
Swap_T := Etype (Swap_F);
else pragma Assert (T_Size <= 64);
Swap_RE := RE_Bswap_64;
end if;
Swap_F := RTE (Swap_RE);
Swap_T := Etype (Swap_F);
Shift := Esize (Swap_T) - T_Size;
Arg := RJ_Unchecked_Convert_To (Swap_T, N);
@ -601,10 +607,14 @@ package body Exp_Pakd is
Right_Opnd => Make_Integer_Literal (Loc, Shift));
end if;
Swapped :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Swap_F, Loc),
Parameter_Associations => New_List (Arg));
if Present (Swap_F) then
Swapped :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Swap_F, Loc),
Parameter_Associations => New_List (Arg));
else
Swapped := Arg;
end if;
if Right_Justify and then Shift > Uint_0 then
Swapped :=

20
gcc/ada/s-taprop.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -324,15 +324,15 @@ package System.Task_Primitives.Operations is
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False);
pragma Inline (Set_Priority);
-- Set the priority of the task specified by T to T.Current_Priority. The
-- priority set is what would correspond to the Ada concept of "base
-- priority" in the terms of the lower layer system, but the operation may
-- be used by the upper layer to implement changes in "active priority"
-- that are not due to lock effects. The effect should be consistent with
-- the Ada Reference Manual. In particular, when a task lowers its
-- priority due to the loss of inherited priority, it goes at the head of
-- the queue for its new priority (RM D.2.2 par 9). Loss_Of_Inheritance
-- helps the underlying implementation to do it right when the OS doesn't.
-- Set the priority of the task specified by T to Prio. The priority set
-- is what would correspond to the Ada concept of "base priority" in the
-- terms of the lower layer system, but the operation may be used by the
-- upper layer to implement changes in "active priority" that are not due
-- to lock effects. The effect should be consistent with the Ada Reference
-- Manual. In particular, when a task lowers its priority due to the loss
-- of inherited priority, it goes at the head of the queue for its new
-- priority (RM D.2.2 par 9). Loss_Of_Inheritance helps the underlying
-- implementation to do it right when the OS doesn't.
function Get_Priority (T : ST.Task_Id) return System.Any_Priority;
pragma Inline (Get_Priority);

53
gcc/ada/sem_ch12.adb
View file

@ -9941,6 +9941,58 @@ package body Sem_Ch12 is
-- List of primitives made temporarily visible in the instantiation
-- to match the visibility of the formal type
procedure Check_Initialized_Types;
-- In a generic package body, an entity of a generic private type may
-- appear uninitialized. This is suspicious, unless the actual is a
-- fully initialized type.
procedure Check_Initialized_Types is
Decl : Node_Id;
Formal : Entity_Id;
Actual : Entity_Id;
begin
Decl := First (Generic_Formal_Declarations (Gen_Decl));
while Present (Decl) loop
if (Nkind (Decl) = N_Private_Extension_Declaration
and then Needs_Initialized_Actual (Decl))
or else (Nkind (Decl) = N_Formal_Type_Declaration
and then
Nkind (Formal_Type_Definition (Decl)) =
N_Formal_Private_Type_Definition
and then Needs_Initialized_Actual
(Formal_Type_Definition (Decl)))
then
Formal := Defining_Identifier (Decl);
Actual := First_Entity (Act_Decl_Id);
-- For each formal there is a subtype declaration that renames
-- the actual and has the same name as the formal.
while Present (Actual) loop
exit when Ekind (Actual) = E_Package
and then Present (Renamed_Object (Actual));
if Chars (Actual) = Chars (Formal)
and then not Is_Scalar_Type (Actual)
and then not Is_Fully_Initialized_Type (Actual)
and then Warn_On_No_Value_Assigned
then
Error_Msg_NE
("from its use in generic unit, actual for&"
& " should be fully initialized type?",
Actual, Formal);
exit;
end if;
Next_Entity (Actual);
end loop;
end if;
Next (Decl);
end loop;
end Check_Initialized_Types;
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
@ -10013,6 +10065,7 @@ package body Sem_Ch12 is
Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
Check_Generic_Actuals (Act_Decl_Id, False);
Check_Initialized_Types;
-- Install primitives hidden at the point of the instantiation but
-- visible when processing the generic formals

110
gcc/ada/sem_ch3.adb
View file

@ -919,19 +919,16 @@ package body Sem_Ch3 is
-- include an expression that is an allocator, whose expansion needs the
-- proper Master for the created tasks.
if Nkind (Related_Nod) = N_Object_Declaration
and then Expander_Active
if Nkind (Related_Nod) = N_Object_Declaration and then Expander_Active
then
if Is_Interface (Desig_Type)
and then Is_Limited_Record (Desig_Type)
if Is_Interface (Desig_Type) and then Is_Limited_Record (Desig_Type)
then
Build_Class_Wide_Master (Anon_Type);
-- Similarly, if the type is an anonymous access that designates
-- tasks, create a master entity for it in the current context.
elsif Has_Task (Desig_Type)
and then Comes_From_Source (Related_Nod)
elsif Has_Task (Desig_Type) and then Comes_From_Source (Related_Nod)
then
Build_Master_Entity (Defining_Identifier (Related_Nod));
Build_Master_Renaming (Anon_Type);
@ -1205,8 +1202,7 @@ package body Sem_Ch3 is
-- use previous subprogram type as the designated type, and then
-- remove scope added above.
if ASIS_Mode
and then Present (Scope (Defining_Identifier (F)))
if ASIS_Mode and then Present (Scope (Defining_Identifier (F)))
then
Set_Etype (T_Name, T_Name);
Init_Size_Align (T_Name);
@ -1355,8 +1351,7 @@ package body Sem_Ch3 is
-- its own context, allowing the following circularity that cannot be
-- detected earlier
elsif Is_Class_Wide_Type (Full_Desig)
and then Etype (Full_Desig) = T
elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T
then
Error_Msg_N
("access type cannot designate its own classwide type", S);
@ -1755,9 +1750,8 @@ package body Sem_Ch3 is
case Nkind (Constr) is
when N_Attribute_Reference =>
return
Attribute_Name (Constr) = Name_Access
and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
return Attribute_Name (Constr) = Name_Access
and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
when N_Discriminant_Association =>
return Denotes_Discriminant (Expression (Constr));
@ -2319,9 +2313,7 @@ package body Sem_Ch3 is
-- ??? a cleaner approach may be possible and/or this solution
-- could be extended to general-purpose late primitives, TBD.
if not ASIS_Mode
and then not Body_Seen
and then not Is_Body (Decl)
if not ASIS_Mode and then not Body_Seen and then not Is_Body (Decl)
then
Body_Seen := True;
@ -2472,8 +2464,7 @@ package body Sem_Ch3 is
-- imported through a LIMITED WITH clause, it appears as incomplete
-- but has no full view.
if Ekind (Prev) = E_Incomplete_Type
and then Present (Full_View (Prev))
if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev))
then
T := Full_View (Prev);
else
@ -3196,7 +3187,6 @@ package body Sem_Ch3 is
if Present (Prev_Entity)
and then
-- If the homograph is an implicit subprogram, it is overridden
-- by the current declaration.
@ -3274,12 +3264,11 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-- out some static checks
if Ada_Version >= Ada_2005
and then Can_Never_Be_Null (T)
then
if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then
-- In case of aggregates we must also take care of the correct
-- initialization of nested aggregates bug this is done at the
-- point of the analysis of the aggregate (see sem_aggr.adb)
-- point of the analysis of the aggregate (see sem_aggr.adb).
if Present (Expression (N))
and then Nkind (Expression (N)) = N_Aggregate
@ -3523,9 +3512,7 @@ package body Sem_Ch3 is
Set_Current_Value (Id, E);
end if;
elsif Is_Scalar_Type (T)
and then Is_OK_Static_Expression (E)
then
elsif Is_Scalar_Type (T) and then Is_OK_Static_Expression (E) then
Set_Is_Known_Valid (Id);
end if;
@ -3534,9 +3521,7 @@ package body Sem_Ch3 is
if Is_Access_Type (T) then
if Known_Non_Null (E) then
Set_Is_Known_Non_Null (Id, True);
elsif Known_Null (E)
and then not Can_Never_Be_Null (Id)
then
elsif Known_Null (E) and then not Can_Never_Be_Null (Id) then
Set_Is_Known_Null (Id, True);
end if;
end if;
@ -3973,9 +3958,7 @@ package body Sem_Ch3 is
declare
Val : constant Node_Id := Constant_Value (Entity (E));
begin
if Present (Val)
and then Nkind (Val) = N_String_Literal
then
if Present (Val) and then Nkind (Val) = N_String_Literal then
Rewrite (E, New_Copy (Val));
end if;
end;
@ -4027,8 +4010,7 @@ package body Sem_Ch3 is
-- Deal with setting In_Private_Part flag if in private part
if Ekind (Scope (Id)) = E_Package
and then In_Private_Part (Scope (Id))
if Ekind (Scope (Id)) = E_Package and then In_Private_Part (Scope (Id))
then
Set_In_Private_Part (Id);
end if;
@ -4125,8 +4107,8 @@ package body Sem_Ch3 is
pragma Assert (Prev = T
or else (Ekind (Prev) = E_Incomplete_Type
and then Present (Full_View (Prev))
and then Full_View (Prev) = T));
and then Present (Full_View (Prev))
and then Full_View (Prev) = T));
end;
end if;
@ -4211,9 +4193,7 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-443): Synchronized private extension or a rewritten
-- synchronized formal derived type.
if Ada_Version >= Ada_2005
and then Synchronized_Present (N)
then
if Ada_Version >= Ada_2005 and then Synchronized_Present (N) then
Set_Is_Limited_Record (T);
-- Formal derived type case
@ -4224,9 +4204,9 @@ package body Sem_Ch3 is
-- interface.
if (not Is_Tagged_Type (Parent_Type)
or else not Is_Limited_Type (Parent_Type))
or else not Is_Limited_Type (Parent_Type))
and then
(not Is_Interface (Parent_Type)
(not Is_Interface (Parent_Type)
or else not Is_Synchronized_Interface (Parent_Type))
then
Error_Msg_NE ("parent type of & must be tagged limited " &
@ -4264,8 +4244,7 @@ package body Sem_Ch3 is
else
if not Is_Interface (Parent_Type)
or else (not Is_Limited_Interface (Parent_Type)
and then
not Is_Synchronized_Interface (Parent_Type))
and then not Is_Synchronized_Interface (Parent_Type))
then
Error_Msg_NE
("parent type of & must be limited interface", N, T);
@ -4459,9 +4438,7 @@ package body Sem_Ch3 is
-- Subtype of unconstrained array without constraint is not allowed
-- in SPARK.
if Is_Array_Type (T)
and then not Is_Constrained (T)
then
if Is_Array_Type (T) and then not Is_Constrained (T) then
Check_SPARK_Restriction
("subtype of unconstrained array must have constraint", N);
end if;
@ -4748,11 +4725,11 @@ package body Sem_Ch3 is
if Present (Generic_Parent_Type (N))
and then
(Nkind
(Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
(Nkind (Parent (Generic_Parent_Type (N))) /=
N_Formal_Type_Declaration
or else Nkind
(Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
/= N_Formal_Private_Type_Definition)
(Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) /=
N_Formal_Private_Type_Definition)
then
if Is_Tagged_Type (Id) then
@ -4773,9 +4750,7 @@ package body Sem_Ch3 is
end if;
end if;
if Is_Private_Type (T)
and then Present (Full_View (T))
then
if Is_Private_Type (T) and then Present (Full_View (T)) then
Conditional_Delay (Id, Full_View (T));
-- The subtypes of components or subcomponents of protected types
@ -4807,8 +4782,7 @@ package body Sem_Ch3 is
-- In the array case, check compatibility for each index
elsif Is_Array_Type (Etype (Id))
and then Present (First_Index (Id))
elsif Is_Array_Type (Etype (Id)) and then Present (First_Index (Id))
then
-- This really should be a subprogram that finds the indications
-- to check???
@ -4823,7 +4797,7 @@ package body Sem_Ch3 is
begin
while Present (Subt_Index) loop
if ((Nkind (Subt_Index) = N_Identifier
and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
or else Nkind (Subt_Index) = N_Subtype_Indication)
and then
Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range
@ -5230,9 +5204,7 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
-- array type to ensure that objects of this type are initialized.
if Ada_Version >= Ada_2005
and then Can_Never_Be_Null (Element_Type)
then
if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Element_Type) then
Set_Can_Never_Be_Null (T);
if Null_Exclusion_Present (Component_Definition (Def))
@ -5292,9 +5264,7 @@ package body Sem_Ch3 is
-- types created for packed entities do not need such, they are
-- compatible with the user-defined type.
if Number_Dimensions (T) = 1
and then not Is_Packed_Array_Type (T)
then
if Number_Dimensions (T) = 1 and then not Is_Packed_Array_Type (T) then
New_Concatenation_Op (T);
end if;
@ -5587,6 +5557,8 @@ package body Sem_Ch3 is
if Null_Exclusion_Present (Type_Definition (N)) then
Set_Can_Never_Be_Null (Derived_Type);
-- What is with the "AND THEN FALSE" here ???
if Can_Never_Be_Null (Parent_Type)
and then False
then
@ -7453,20 +7425,6 @@ package body Sem_Ch3 is
and then Has_Discriminants (Parent_Type)
then
Parent_Base := Base_Type (Full_View (Parent_Type));
-- Handle a derived type which is the full view of a private type not
-- defined in a generic unit which is derived from a private type with
-- discriminants whose full view is a non-tagged record type.
elsif not Inside_A_Generic
and then Ekind (Parent_Type) = E_Private_Type
and then Has_Discriminants (Parent_Type)
and then Present (Full_View (Parent_Type))
and then Is_Record_Type (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type))
and then Has_Private_Declaration (Derived_Type)
then
Parent_Base := Base_Type (Full_View (Parent_Type));
else
Parent_Base := Base_Type (Parent_Type);
end if;

275
gcc/ada/sem_ch6.adb
View file

@ -2147,6 +2147,10 @@ package body Sem_Ch6 is
-- chained beyond that point. It is initialized to Empty to deal with
-- the case where there is no separate spec.
procedure Analyze_Aspects_On_Body_Or_Stub;
-- Analyze the aspect specifications of a subprogram body [stub]. It is
-- assumed that N has aspects.
procedure Check_Anonymous_Return;
-- Ada 2005: if a function returns an access type that denotes a task,
-- or a type that contains tasks, we must create a master entity for
@ -2169,11 +2173,6 @@ package body Sem_Ch6 is
-- verify that a function ends with a RETURN and that a procedure does
-- not contain any RETURN.
procedure Diagnose_Misplaced_Aspect_Specifications;
-- It is known that subprogram body N has aspects, but they are not
-- properly placed. Provide specific error messages depending on the
-- aspects involved.
function Disambiguate_Spec return Entity_Id;
-- When a primitive is declared between the private view and the full
-- view of a concurrent type which implements an interface, a special
@ -2203,6 +2202,127 @@ package body Sem_Ch6 is
-- indicator, check that it is consistent with the known status of the
-- entity.
-------------------------------------
-- Analyze_Aspects_On_Body_Or_Stub --
-------------------------------------
procedure Analyze_Aspects_On_Body_Or_Stub is
procedure Diagnose_Misplaced_Aspects;
-- Subprogram body [stub] N has aspects, but they are not properly
-- placed. Provide precise diagnostics depending on the aspects
-- involved.
--------------------------------
-- Diagnose_Misplaced_Aspects --
--------------------------------
procedure Diagnose_Misplaced_Aspects is
Asp : Node_Id;
Asp_Nam : Name_Id;
Asp_Id : Aspect_Id;
-- The current aspect along with its name and id
procedure SPARK_Aspect_Error (Ref_Nam : Name_Id);
-- Emit an error message concerning SPARK aspect Asp. Ref_Nam is
-- the name of the refined version of the aspect.
------------------------
-- SPARK_Aspect_Error --
------------------------
procedure SPARK_Aspect_Error (Ref_Nam : Name_Id) is
begin
-- The corresponding spec already contains the aspect in
-- question and the one appearing on the body must be the
-- refined form:
-- procedure P with Global ...;
-- procedure P with Global ... is ... end P;
-- ^
-- Refined_Global
if Has_Aspect (Spec_Id, Asp_Id) then
Error_Msg_Name_1 := Asp_Nam;
-- Subunits cannot carry aspects that apply to a subprogram
-- declaration.
if Nkind (Parent (N)) = N_Subunit then
Error_Msg_N ("aspect % cannot apply to a subunit", Asp);
else
Error_Msg_Name_2 := Ref_Nam;
Error_Msg_N ("aspect % should be %", Asp);
end if;
-- Otherwise the aspect must appear in the spec, not in the
-- body:
-- procedure P;
-- procedure P with Global ... is ... end P;
else
Error_Msg_N
("aspect specification must appear in subprogram "
& "declaration", Asp);
end if;
end SPARK_Aspect_Error;
-- Start of processing for Diagnose_Misplaced_Aspects
begin
-- Iterate over the aspect specifications and emit specific errors
-- where applicable.
Asp := First (Aspect_Specifications (N));
while Present (Asp) loop
Asp_Nam := Chars (Identifier (Asp));
Asp_Id := Get_Aspect_Id (Asp_Nam);
-- Do not emit errors on aspects that can appear on a
-- subprogram body. This scenario occurs when the aspect
-- specification list contains both misplaced and properly
-- placed aspects.
if Aspect_On_Body_Or_Stub_OK (Asp_Id) then
null;
-- Special diagnostics for SPARK aspects
elsif Asp_Nam = Name_Depends then
SPARK_Aspect_Error (Name_Refined_Depends);
elsif Asp_Nam = Name_Global then
SPARK_Aspect_Error (Name_Refined_Global);
elsif Asp_Nam = Name_Post then
SPARK_Aspect_Error (Name_Refined_Post);
else
Error_Msg_N
("aspect specification must appear in subprogram "
& "declaration", Asp);
end if;
Next (Asp);
end loop;
end Diagnose_Misplaced_Aspects;
-- Start of processing for Analyze_Aspects_On_Body_Or_Stub
begin
-- Language-defined aspects cannot be associated with a subprogram
-- body [stub] if the subprogram has a spec. Certain implementation
-- defined aspects are allowed to break this rule (for list, see
-- table Aspect_On_Body_Or_Stub_OK).
if Present (Spec_Id) and then not Aspects_On_Body_Or_Stub_OK (N) then
Diagnose_Misplaced_Aspects;
else
Analyze_Aspect_Specifications (N, Body_Id);
end if;
end Analyze_Aspects_On_Body_Or_Stub;
----------------------------
-- Check_Anonymous_Return --
----------------------------
@ -2455,99 +2575,6 @@ package body Sem_Ch6 is
end if;
end Check_Missing_Return;
----------------------------------------------
-- Diagnose_Misplaced_Aspect_Specifications --
----------------------------------------------
procedure Diagnose_Misplaced_Aspect_Specifications is
Asp : Node_Id;
Asp_Nam : Name_Id;
Asp_Id : Aspect_Id;
-- The current aspect along with its name and id
procedure SPARK_Aspect_Error (Ref_Nam : Name_Id);
-- Emit an error message concerning SPARK aspect Asp. Ref_Nam is the
-- name of the refined version of the aspect.
------------------------
-- SPARK_Aspect_Error --
------------------------
procedure SPARK_Aspect_Error (Ref_Nam : Name_Id) is
begin
-- The corresponding spec already contains the aspect in question
-- and the one appearing on the body must be the refined form:
-- procedure P with Global ...;
-- procedure P with Global ... is ... end P;
-- ^
-- Refined_Global
if Has_Aspect (Spec_Id, Asp_Id) then
Error_Msg_Name_1 := Asp_Nam;
-- Subunits cannot carry aspects that apply to a subprogram
-- declaration.
if Nkind (Parent (N)) = N_Subunit then
Error_Msg_N ("aspect % cannot apply to a subunit", Asp);
else
Error_Msg_Name_2 := Ref_Nam;
Error_Msg_N ("aspect % should be %", Asp);
end if;
-- Otherwise the aspect must appear in the spec, not in the body:
-- procedure P;
-- procedure P with Global ... is ... end P;
else
Error_Msg_N
("aspect specification must appear in subprogram declaration",
Asp);
end if;
end SPARK_Aspect_Error;
-- Start of processing for Diagnose_Misplaced_Aspect_Specifications
begin
-- Iterate over the aspect specifications and emit specific errors
-- where applicable.
Asp := First (Aspect_Specifications (N));
while Present (Asp) loop
Asp_Nam := Chars (Identifier (Asp));
Asp_Id := Get_Aspect_Id (Asp_Nam);
-- Do not emit errors on aspects that can appear on a subprogram
-- body. This scenario occurs when the aspect specification list
-- contains both misplaced and properly placed aspects.
if Aspect_On_Body_Or_Stub_OK (Asp_Id) then
null;
-- Special diagnostics for SPARK aspects
elsif Asp_Nam = Name_Depends then
SPARK_Aspect_Error (Name_Refined_Depends);
elsif Asp_Nam = Name_Global then
SPARK_Aspect_Error (Name_Refined_Global);
elsif Asp_Nam = Name_Post then
SPARK_Aspect_Error (Name_Refined_Post);
else
Error_Msg_N
("aspect specification must appear in subprogram declaration",
Asp);
end if;
Next (Asp);
end loop;
end Diagnose_Misplaced_Aspect_Specifications;
-----------------------
-- Disambiguate_Spec --
-----------------------
@ -2948,21 +2975,6 @@ package body Sem_Ch6 is
end if;
end if;
-- Language-defined aspects cannot appear on a subprogram body [stub] if
-- the subprogram has a spec. Certain implementation-defined aspects are
-- allowed to break this rule (see table Aspect_On_Body_Or_Stub_OK).
if Has_Aspects (N) then
if Present (Spec_Id)
and then not Aspects_On_Body_Or_Stub_OK (N)
then
Diagnose_Misplaced_Aspect_Specifications;
else
Analyze_Aspect_Specifications (N, Body_Id);
end if;
end if;
-- Previously we scanned the body to look for nested subprograms, and
-- rejected an inline directive if nested subprograms were present,
-- because the back-end would generate conflicting symbols for the
@ -3299,6 +3311,17 @@ package body Sem_Ch6 is
Check_Eliminated (Body_Id);
if Nkind (N) = N_Subprogram_Body_Stub then
-- Analyze any aspect specifications that appear on the subprogram
-- body stub.
if Has_Aspects (N) then
Analyze_Aspects_On_Body_Or_Stub;
end if;
-- Stop the analysis now as the stub cannot be inlined, plus it does
-- not have declarative or statement lists.
return;
end if;
@ -3372,16 +3395,6 @@ package body Sem_Ch6 is
HSS := Handled_Statement_Sequence (N);
Set_Actual_Subtypes (N, Current_Scope);
-- Deal with [refined] preconditions, postconditions, Contract_Cases,
-- invariants and predicates associated with the body and its spec.
-- Note that this is not pure expansion as Expand_Subprogram_Contract
-- prepares the contract assertions for generic subprograms or for ASIS.
-- Do not generate contract checks in SPARK mode.
if not GNATprove_Mode then
Expand_Subprogram_Contract (N, Spec_Id, Body_Id);
end if;
-- Add a declaration for the Protection object, renaming declarations
-- for discriminals and privals and finally a declaration for the entry
-- family index (if applicable). This form of early expansion is done
@ -3409,6 +3422,22 @@ package body Sem_Ch6 is
Exchange_Limited_Views (Spec_Id);
end if;
-- Analyze any aspect specifications that appear on the subprogram body
if Has_Aspects (N) then
Analyze_Aspects_On_Body_Or_Stub;
end if;
-- Deal with [refined] preconditions, postconditions, Contract_Cases,
-- invariants and predicates associated with the body and its spec.
-- Note that this is not pure expansion as Expand_Subprogram_Contract
-- prepares the contract assertions for generic subprograms or for ASIS.
-- Do not generate contract checks in SPARK mode.
if not GNATprove_Mode then
Expand_Subprogram_Contract (N, Spec_Id, Body_Id);
end if;
-- Analyze the declarations (this call will analyze the precondition
-- Check pragmas we prepended to the list, as well as the declaration
-- of the _Postconditions procedure).

8
gcc/ada/sem_ch8.adb
View file

@ -2505,12 +2505,18 @@ package body Sem_Ch8 is
end if;
end if;
-- At this point, we used to have the following, but we removed it
-- because it was certainly wrong for generic formal parameters in
-- at least some cases, causing elaboration checks to be skipped.
-- Possibly it is helpful in some other cases, but it caused no
-- regressions to remove it completely.
-- There is no need for elaboration checks on the new entity, which may
-- be called before the next freezing point where the body will appear.
-- Elaboration checks refer to the real entity, not the one created by
-- the renaming declaration.
Set_Kill_Elaboration_Checks (New_S, True);
-- Set_Kill_Elaboration_Checks (New_S, True);
if Etype (Nam) = Any_Type then
Set_Has_Completion (New_S);

107
gcc/ada/sem_elab.adb
View file

@ -578,16 +578,15 @@ package body Sem_Elab is
if Nkind (Decl) = N_Subprogram_Body then
Body_Acts_As_Spec := True;
elsif Nkind (Decl) = N_Subprogram_Declaration
or else Nkind (Decl) = N_Subprogram_Body_Stub
elsif Nkind_In (Decl, N_Subprogram_Declaration, N_Subprogram_Body_Stub)
or else Inst_Case
then
Body_Acts_As_Spec := False;
-- If we have none of an instantiation, subprogram body or
-- subprogram declaration, then it is not a case that we want
-- to check. (One case is a call to a generic formal subprogram,
-- where we do not want the check in the template).
-- If we have none of an instantiation, subprogram body or subprogram
-- declaration, then it is not a case that we want to check. (One case
-- is a call to a generic formal subprogram, where we do not want the
-- check in the template).
else
return;
@ -605,7 +604,7 @@ package body Sem_Elab is
exit when Is_Compilation_Unit (E_Scope)
and then (Is_Child_Unit (E_Scope)
or else Scope (E_Scope) = Standard_Standard);
or else Scope (E_Scope) = Standard_Standard);
-- If we did not find a compilation unit, other than standard,
-- then nothing to check (happens in some instantiation cases)
@ -633,17 +632,15 @@ package body Sem_Elab is
-- However, this assumption is only valid if we are in static mode.
if not Dynamic_Elaboration_Checks
and then Instantiation_Depth (Sloc (Ent)) >
Instantiation_Depth (Sloc (N))
and then
Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N))
then
return;
end if;
-- Do not give a warning for a package with no body
if Ekind (Ent) = E_Generic_Package
and then not Has_Generic_Body (N)
then
if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then
return;
end if;
@ -738,7 +735,7 @@ package body Sem_Elab is
-- the sgi build and storage errors. To be resolved later ???
if (Callee_Unit_Internal and Caller_Unit_Internal)
and then not Debug_Flag_EE
and then not Debug_Flag_EE
then
return;
end if;
@ -776,7 +773,14 @@ package body Sem_Elab is
if Unit_Caller /= No_Unit
and then Unit_Callee /= Unit_Caller
and then not Dynamic_Elaboration_Checks
-- This is an attempt to solve the problem of mishandling of
-- generic formal parameters, but it does not work right yet ???
-- and then not Used_As_Generic_Actual (Ent)
then
-- It is here that things go wrong for calling a generic formal???
E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
-- If we don't get a spec entity, just ignore call. Not quite
@ -802,9 +806,7 @@ package body Sem_Elab is
-- Loop to carefully follow renamings and derivations one step
-- outside the current unit, but not further.
if not Inst_Case
and then Present (Alias (Ent))
then
if not Inst_Case and then Present (Alias (Ent)) then
E_Scope := Alias (Ent);
else
E_Scope := Ent;
@ -1182,7 +1184,7 @@ package body Sem_Elab is
-- For an entry call, check relevant restriction
if Nkind (N) = N_Entry_Call_Statement
and then not In_Subprogram_Or_Concurrent_Unit
and then not In_Subprogram_Or_Concurrent_Unit
then
Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
@ -1339,9 +1341,8 @@ package body Sem_Elab is
-- Filter out case of default expressions, where we do not
-- do the check at this stage.
if Nkind (P) = N_Parameter_Specification
or else
Nkind (P) = N_Component_Declaration
if Nkind_In (P, N_Parameter_Specification,
N_Component_Declaration)
then
return;
end if;
@ -1352,13 +1353,10 @@ package body Sem_Elab is
if Nkind (P) = N_Protected_Body then
return;
elsif Nkind (P) = N_Subprogram_Body
or else
Nkind (P) = N_Task_Body
or else
Nkind (P) = N_Block_Statement
or else
Nkind (P) = N_Entry_Body
elsif Nkind_In (P, N_Subprogram_Body,
N_Task_Body,
N_Block_Statement,
N_Entry_Body)
then
if L = Declarations (P) then
exit;
@ -1499,9 +1497,7 @@ package body Sem_Elab is
-- treat the current node as a call to each of these functions, to check
-- their elaboration impact.
if Is_Init_Proc (Ent)
and then From_Elab_Code
then
if Is_Init_Proc (Ent) and then From_Elab_Code then
Process_Init_Proc : declare
Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
@ -1713,7 +1709,7 @@ package body Sem_Elab is
begin
if Nkind (Decl) = N_Object_Declaration
and then (Present (Expression (Decl))
or else No_Initialization (Decl))
or else No_Initialization (Decl))
then
return;
end if;
@ -1842,9 +1838,7 @@ package body Sem_Elab is
C_Scope := Current_Scope;
if Present (Outer_Scope)
and then Within (Scope (Ent), Outer_Scope)
then
if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then
Set_C_Scope;
Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
@ -1992,8 +1986,8 @@ package body Sem_Elab is
-- code, do not trace past an accept statement, because the rendez-
-- vous will happen after elaboration.
if (Nkind (Original_Node (N)) = N_Accept_Statement
or else Nkind (Original_Node (N)) = N_Selective_Accept)
if Nkind_In (Original_Node (N), N_Accept_Statement,
N_Selective_Accept)
and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
then
return Abandon;
@ -2021,8 +2015,8 @@ package body Sem_Elab is
return OK;
-- If we have an access attribute for a subprogram, check
-- it. Suppress this behavior under debug flag.
-- If we have an access attribute for a subprogram, check it.
-- Suppress this behavior under debug flag.
elsif not Debug_Flag_Dot_UU
and then Nkind (N) = N_Attribute_Reference
@ -2086,10 +2080,7 @@ package body Sem_Elab is
Sbody := Unit_Declaration_Node (E);
if Nkind (Sbody) /= N_Subprogram_Body
and then
Nkind (Sbody) /= N_Package_Body
then
if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then
Ebody := Corresponding_Body (Sbody);
if No (Ebody) then
@ -2406,8 +2397,7 @@ package body Sem_Elab is
if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
and then
(not Is_Generic_Instance (Scope (Proc))
or else
Scope (Proc) = Scope (Defining_Identifier (Decl)))
or else Scope (Proc) = Scope (Defining_Identifier (Decl)))
then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N
@ -2636,9 +2626,8 @@ package body Sem_Elab is
-- that is, on which we need to place to elaboration flag. This happens
-- with init proc calls.
if Is_Init_Proc (Subp)
or else Init_Call
then
if Is_Init_Proc (Subp) or else Init_Call then
-- The initialization call is on an object whose type is not declared
-- in the same scope as the subprogram. The type of the object must
-- be a subtype of the type of operation. This object is the first
@ -2996,9 +2985,7 @@ package body Sem_Elab is
begin
-- Check whether Id is a procedure with at least one parameter
if Ekind (Id) = E_Procedure
and then Present (First_Formal (Id))
then
if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then
declare
Typ : constant Entity_Id := Etype (First_Formal (Id));
Deep_Fin : Entity_Id := Empty;
@ -3025,10 +3012,8 @@ package body Sem_Elab is
Fin := Find_Prim_Op (Typ, Name_Finalize);
end if;
return
(Present (Deep_Fin) and then Id = Deep_Fin)
or else
(Present (Fin) and then Id = Fin);
return (Present (Deep_Fin) and then Id = Deep_Fin)
or else (Present (Fin) and then Id = Fin);
end;
end if;
@ -3100,11 +3085,7 @@ package body Sem_Elab is
S1 := Scop1;
while S1 /= Standard_Standard
and then not Is_Compilation_Unit (S1)
and then (Ekind (S1) = E_Package
or else
Ekind (S1) = E_Protected_Type
or else
Ekind (S1) = E_Block)
and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block)
loop
S1 := Scope (S1);
end loop;
@ -3114,11 +3095,7 @@ package body Sem_Elab is
S2 := Scop2;
while S2 /= Standard_Standard
and then not Is_Compilation_Unit (S2)
and then (Ekind (S2) = E_Package
or else
Ekind (S2) = E_Protected_Type
or else
Ekind (S2) = E_Block)
and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block)
loop
S2 := Scope (S2);
end loop;
@ -3172,8 +3149,8 @@ package body Sem_Elab is
if Nkind (N) = N_Subprogram_Declaration then
declare
Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
begin
begin
-- Internal subprograms will already have a generated body, so
-- there is no need to provide a stub for them.

44
gcc/ada/sem_eval.adb
View file

@ -5530,7 +5530,7 @@ package body Sem_Eval is
if Raises_Constraint_Error (Expr) then
Error_Msg_N
("\expression raises exception, cannot be static " &
("!expression raises exception, cannot be static " &
"(RM 4.9(34))", N);
return;
end if;
@ -5551,7 +5551,7 @@ package body Sem_Eval is
and then not Is_RTE (Typ, RE_Bignum)
then
Error_Msg_N
("\static expression must have scalar or string type " &
("!static expression must have scalar or string type " &
"(RM 4.9(2))", N);
return;
end if;
@ -5615,17 +5615,17 @@ package body Sem_Eval is
or else
Is_Aggregate (Right_Opnd (CO))))
then
Error_Msg_N ("\aggregate (#) is never static", N);
Error_Msg_N ("!aggregate (#) is never static", N);
elsif No (CV) or else not Is_Static_Expression (CV) then
Error_Msg_NE
("\& is not a static constant (RM 4.9(5))", N, E);
("!& is not a static constant (RM 4.9(5))", N, E);
end if;
end Entity_Case;
else
Error_Msg_NE
("\& is not static constant or named number "
("!& is not static constant or named number "
& "(RM 4.9(5))", N, E);
end if;
@ -5634,7 +5634,7 @@ package body Sem_Eval is
when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
if Nkind (N) in N_Op_Shift then
Error_Msg_N
("\shift functions are never static (RM 4.9(6,18))", N);
("!shift functions are never static (RM 4.9(6,18))", N);
else
Why_Not_Static (Left_Opnd (N));
@ -5661,7 +5661,7 @@ package body Sem_Eval is
if Attribute_Name (N) = Name_Size then
Error_Msg_N
("\size attribute is only static for static scalar type "
("!size attribute is only static for static scalar type "
& "(RM 4.9(7,8))", N);
-- Flag array cases
@ -5674,7 +5674,7 @@ package body Sem_Eval is
Attribute_Name (N) /= Name_Length
then
Error_Msg_N
("\static array attribute must be Length, First, or Last "
("!static array attribute must be Length, First, or Last "
& "(RM 4.9(8))", N);
-- Since we know the expression is not-static (we already
@ -5682,7 +5682,7 @@ package body Sem_Eval is
else
Error_Msg_N
("\prefix is non-static array (RM 4.9(8))", Prefix (N));
("!prefix is non-static array (RM 4.9(8))", Prefix (N));
end if;
return;
@ -5695,7 +5695,7 @@ package body Sem_Eval is
Is_Generic_Type (E)
then
Error_Msg_N
("\attribute of generic type is never static "
("!attribute of generic type is never static "
& "(RM 4.9(7,8))", N);
elsif Is_Static_Subtype (E) then
@ -5703,12 +5703,12 @@ package body Sem_Eval is
elsif Is_Scalar_Type (E) then
Error_Msg_N
("\prefix type for attribute is not static scalar subtype "
("!prefix type for attribute is not static scalar subtype "
& "(RM 4.9(7))", N);
else
Error_Msg_N
("\static attribute must apply to array/scalar type "
("!static attribute must apply to array/scalar type "
& "(RM 4.9(7,8))", N);
end if;
@ -5716,13 +5716,13 @@ package body Sem_Eval is
when N_String_Literal =>
Error_Msg_N
("\subtype of string literal is non-static (RM 4.9(4))", N);
("!subtype of string literal is non-static (RM 4.9(4))", N);
-- Explicit dereference
when N_Explicit_Dereference =>
Error_Msg_N
("\explicit dereference is never static (RM 4.9)", N);
("!explicit dereference is never static (RM 4.9)", N);
-- Function call
@ -5734,7 +5734,7 @@ package body Sem_Eval is
-- scalar arithmetic operation.
if not Is_RTE (Typ, RE_Bignum) then
Error_Msg_N ("\non-static function call (RM 4.9(6,18))", N);
Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
end if;
-- Parameter assocation (test actual parameter)
@ -5745,12 +5745,12 @@ package body Sem_Eval is
-- Indexed component
when N_Indexed_Component =>
Error_Msg_N ("\indexed component is never static (RM 4.9)", N);
Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
-- Procedure call
when N_Procedure_Call_Statement =>
Error_Msg_N ("\procedure call is never static (RM 4.9)", N);
Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
-- Qualified expression (test expression)
@ -5760,7 +5760,7 @@ package body Sem_Eval is
-- Aggregate
when N_Aggregate | N_Extension_Aggregate =>
Error_Msg_N ("\an aggregate is never static (RM 4.9)", N);
Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
-- Range
@ -5781,12 +5781,12 @@ package body Sem_Eval is
-- Selected component
when N_Selected_Component =>
Error_Msg_N ("\selected component is never static (RM 4.9)", N);
Error_Msg_N ("!selected component is never static (RM 4.9)", N);
-- Slice
when N_Slice =>
Error_Msg_N ("\slice is never static (RM 4.9)", N);
Error_Msg_N ("!slice is never static (RM 4.9)", N);
when N_Type_Conversion =>
Why_Not_Static (Expression (N));
@ -5795,7 +5795,7 @@ package body Sem_Eval is
or else not Is_Static_Subtype (Entity (Subtype_Mark (N)))
then
Error_Msg_N
("\static conversion requires static scalar subtype result "
("!static conversion requires static scalar subtype result "
& "(RM 4.9(9))", N);
end if;
@ -5803,7 +5803,7 @@ package body Sem_Eval is
when N_Unchecked_Type_Conversion =>
Error_Msg_N
("\unchecked type conversion is never static (RM 4.9)", N);
("!unchecked type conversion is never static (RM 4.9)", N);
-- All other cases, no reason to give

30
gcc/ada/sem_eval.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -470,17 +470,23 @@ package Sem_Eval is
procedure Why_Not_Static (Expr : Node_Id);
-- This procedure may be called after generating an error message that
-- complains that something is non-static. If it finds good reasons,
-- it generates one or more continuation error messages pointing the
-- appropriate offending component of the expression. If no good reasons
-- can be figured out, then no messages are generated. The expectation here
-- is that the caller has already issued a message complaining that the
-- expression is non-static. Note that this message should be placed using
-- Error_Msg_F or Error_Msg_FE, so that it will sort before any messages
-- placed by this call. Note that it is fine to call Why_Not_Static with
-- something that is not an expression, and usually this has no effect, but
-- in some cases (N_Parameter_Association or N_Range), it makes sense for
-- the internal recursive calls.
-- complains that something is non-static. If it finds good reasons, it
-- generates one or more error messages pointing the appropriate offending
-- component of the expression. If no good reasons can be figured out, then
-- no messages are generated. The expectation here is that the caller has
-- already issued a message complaining that the expression is non-static.
-- Note that this message should be placed using Error_Msg_F or
-- Error_Msg_FE, so that it will sort before any messages placed by this
-- call. Note that it is fine to call Why_Not_Static with something that
-- is not an expression, and usually this has no effect, but in some cases
-- (N_Parameter_Association or N_Range), it makes sense for the internal
-- recursive calls.
--
-- Note that these messages are not continuation messages, instead they are
-- separate unconditional messages, marked with '!'. The reason for this is
-- that they can be posted at a different location from the maim message as
-- documented above ("appropriate offending component"), and continuation
-- messages must always point to the same location as the parent message.
procedure Initialize;
-- Initializes the internal data structures. Must be called before each

51
gcc/ada/sem_warn.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2014, 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- --
@ -766,6 +766,14 @@ package body Sem_Warn is
-- For an entry formal entity from an entry declaration, find the
-- corresponding body formal from the given accept statement.
function May_Need_Initialized_Actual (Ent : Entity_Id) return Boolean;
-- If an entity of a generic type has default initialization, then the
-- corresponding actual type should be fully initialized, or else there
-- will be uninitialized components in the instantiation, that might go
-- unreported. This predicate allows the compiler to emit an appropriate
-- warning in the generic itself. In a sense, the use of a type that
-- requires full initialization is a weak part of the generic contract.
function Missing_Subunits return Boolean;
-- We suppress warnings when there are missing subunits, because this
-- may generate too many false positives: entities in a parent may only
@ -815,6 +823,44 @@ package body Sem_Warn is
raise Program_Error;
end Body_Formal;
-----------------------------------
-- May_Need_Initialized_Actual --
-----------------------------------
function May_Need_Initialized_Actual (Ent : Entity_Id) return Boolean is
T : constant Entity_Id := Etype (Ent);
Par : constant Node_Id := Parent (T);
Res : Boolean;
begin
if not Is_Generic_Type (T) then
Res := False;
elsif (Nkind (Par)) = N_Private_Extension_Declaration then
Set_Needs_Initialized_Actual (Par);
Res := True;
elsif (Nkind (Par)) = N_Formal_Type_Declaration
and then Nkind (Formal_Type_Definition (Par))
= N_Formal_Private_Type_Definition
then
Set_Needs_Initialized_Actual (Formal_Type_Definition (Par));
Res := True;
else
Res := False;
end if;
if Res then
Error_Msg_N ("?!variable& of a generic type is "
& "potentially uninitialized", Ent);
Error_Msg_NE ("\?instantiations must provide fully initialized "
& "type for&", Ent, T);
end if;
return Res;
end May_Need_Initialized_Actual;
----------------------
-- Missing_Subunits --
----------------------
@ -1266,6 +1312,7 @@ package body Sem_Warn is
if not Has_Unmodified (E1)
and then not Warnings_Off_E1
and then not Is_Junk_Name (Chars (E1))
and then not May_Need_Initialized_Actual (E1)
then
Output_Reference_Error
("?v?variable& is read but never assigned!");
@ -1274,6 +1321,7 @@ package body Sem_Warn is
elsif not Has_Unreferenced (E1)
and then not Warnings_Off_E1
and then not Is_Junk_Name (Chars (E1))
and then not May_Need_Initialized_Actual (E1)
then
Output_Reference_Error -- CODEFIX
("?v?variable& is never read and never assigned!");
@ -1403,6 +1451,7 @@ package body Sem_Warn is
end if;
goto Continue;
end if;
end if;

20
gcc/ada/sinfo.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -2224,6 +2224,15 @@ package body Sinfo is
return List2 (N);
end Names;
function Needs_Initialized_Actual
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Extension_Declaration);
return Flag18 (N);
end Needs_Initialized_Actual;
function Next_Entity
(N : Node_Id) return Node_Id is
begin
@ -5364,6 +5373,15 @@ package body Sinfo is
Set_List2_With_Parent (N, Val);
end Set_Names;
procedure Set_Needs_Initialized_Actual
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Extension_Declaration);
Set_Flag18 (N, Val);
end Set_Needs_Initialized_Actual;
procedure Set_Next_Entity
(N : Node_Id; Val : Node_Id) is
begin

21
gcc/ada/sinfo.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -1701,6 +1701,12 @@ package Sinfo is
-- present in an N_Subtype_Indication node, since we also use these in
-- calls to Freeze_Expression.
-- Needs_Initialized_Actual (Flag18-Sem)
-- Present in formal_private_type_definitions and on private extension
-- declarations. Set when the use of a formal type in a generic suggests
-- that the actual should be a fully initialized type, to avoid potential
-- use of uninitialized values.
-- Next_Entity (Node2-Sem)
-- Present in defining identifiers, defining character literals and
-- defining operator symbols (i.e. in all entities). The entities of a
@ -5280,6 +5286,7 @@ package Sinfo is
-- Synchronized_Present (Flag7)
-- Subtype_Indication (Node5)
-- Interface_List (List2) (set to No_List if none)
-- Needs_Initialized_Actual (Flag18-Sem)
---------------------
-- 8.4 Use Clause --
@ -6705,6 +6712,7 @@ package Sinfo is
-- Abstract_Present (Flag4)
-- Tagged_Present (Flag15)
-- Limited_Present (Flag17)
-- Needs_Initialized_Actual (Flag18-Sem)
--------------------------------------------
-- 12.5.1 Formal Derived Type Definition --
@ -8930,7 +8938,6 @@ package Sinfo is
function Generalized_Indexing
(N : Node_Id) return Node_Id; -- Node4
function Generic_Associations
(N : Node_Id) return List_Id; -- List3
@ -9195,6 +9202,9 @@ package Sinfo is
function Names
(N : Node_Id) return List_Id; -- List2
function Needs_Initialized_Actual
(N : Node_Id) return Boolean; -- Flag18
function Next_Entity
(N : Node_Id) return Node_Id; -- Node2
@ -10194,6 +10204,9 @@ package Sinfo is
procedure Set_Names
(N : Node_Id; Val : List_Id); -- List2
procedure Set_Needs_Initialized_Actual
(N : Node_Id; Val : Boolean := True); -- Flag18
procedure Set_Next_Entity
(N : Node_Id; Val : Node_Id); -- Node2
@ -10940,7 +10953,7 @@ package Sinfo is
(1 => True, -- Expressions (List1)
2 => False, -- unused
3 => True, -- Prefix (Node3)
4 => False, -- Generalized_Indexing (Node4-Sem)
4 => False, -- Generalized_Indexing (Node4-Sem)
5 => False), -- Etype (Node5-Sem)
N_Slice =>
@ -12483,6 +12496,7 @@ package Sinfo is
pragma Inline (Must_Override);
pragma Inline (Name);
pragma Inline (Names);
pragma Inline (Needs_Initialized_Actual);
pragma Inline (Next_Entity);
pragma Inline (Next_Exit_Statement);
pragma Inline (Next_Implicit_With);
@ -12812,6 +12826,7 @@ package Sinfo is
pragma Inline (Set_Must_Override);
pragma Inline (Set_Name);
pragma Inline (Set_Names);
pragma Inline (Set_Needs_Initialized_Actual);
pragma Inline (Set_Next_Entity);
pragma Inline (Set_Next_Exit_Statement);
pragma Inline (Set_Next_Implicit_With);