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

[multiple changes]

Browse Source 
2017-01-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute_Reference, case Loop_Entry):
	Hnadle properly the attribute reference when it appears as part
	of an expression in another loop aspect.

2017-01-12  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb (Check_Predicated_Discriminant): New procedure,
	subsidiary of Build_Initialization_Call, to complete generation
	of predicate checks on discriminants whose (sub)types have
	predicates, and to add checks on variants that do not have an
	others clause.
	* sem_util.adb (Gather_Components): A missing Others alternative is
	not an error when the type of the discriminant is a static predicate
	(and coverage has been checked when analyzing the case statement). A
	runtime check is generated to verify that a given discriminant
	satisfies the predicate (RM 3.8.1. (21.1/2)).

2017-01-12  Yannick Moy  <moy@adacore.com>

	* gnat1drv.adb (Adjust_Global_Switches): Only
	perform checking of exception mechanism when generating code.

2017-01-12  Justin Squirek  <squirek@adacore.com>

	* exp_ch7.adb (Add_Type_Invariants, Process_Array_Component):
	Remove handling of access component with invariant.
	(Build_Invariant_Procedure_Declaration): Remove return on class
	wide type.
	* freeze.adb (Freeze_Array_Type, Freeze_Record_Type): Remove
	conditional exception for component or array so Has_Own_Invariants
	flag is not falsly set.
	* sem_ch3.adb (Make_Class_Wide_Type): Initialize copy of class
	wide type to have no invariant flags.

From-SVN: r244366
This commit is contained in:
Arnaud Charlet 2017-01-12 15:42:42 +01:00
parent 2168d7cc3b
commit 0289a8d7ef
8 changed files with 217 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
gcc/ada/ChangeLog
View File

@ -1,3 +1,39 @@
2017-01-12 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute_Reference, case Loop_Entry):
Hnadle properly the attribute reference when it appears as part
of an expression in another loop aspect.
2017-01-12 Ed Schonberg <schonberg@adacore.com>
* exp_ch3.adb (Check_Predicated_Discriminant): New procedure,
subsidiary of Build_Initialization_Call, to complete generation
of predicate checks on discriminants whose (sub)types have
predicates, and to add checks on variants that do not have an
others clause.
* sem_util.adb (Gather_Components): A missing Others alternative is
not an error when the type of the discriminant is a static predicate
(and coverage has been checked when analyzing the case statement). A
runtime check is generated to verify that a given discriminant
satisfies the predicate (RM 3.8.1. (21.1/2)).
2017-01-12 Yannick Moy <moy@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): Only
perform checking of exception mechanism when generating code.
2017-01-12 Justin Squirek <squirek@adacore.com>
* exp_ch7.adb (Add_Type_Invariants, Process_Array_Component):
Remove handling of access component with invariant.
(Build_Invariant_Procedure_Declaration): Remove return on class
wide type.
* freeze.adb (Freeze_Array_Type, Freeze_Record_Type): Remove
conditional exception for component or array so Has_Own_Invariants
flag is not falsly set.
* sem_ch3.adb (Make_Class_Wide_Type): Initialize copy of class
wide type to have no invariant flags.
2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch9.adb, sem_prag.adb, s-tassta.adb, sem_util.adb, s-tarest.adb,

126
gcc/ada/exp_ch3.adb
View File

@ -1286,7 +1286,118 @@ package body Exp_Ch3 is
With_Default_Init : Boolean := False;
Constructor_Ref : Node_Id := Empty) return List_Id
is
Res : constant List_Id := New_List;
Res : constant List_Id := New_List;
Full_Type : Entity_Id;
procedure Check_Predicated_Discriminant
(Val : Node_Id;
Discr : Entity_Id);
-- Discriminants whose subtypes have predicates are checked in two
-- cases:
-- a) When an object is default-initialized and assertions are enabled
-- we check that the value of the discriminant obeys the predicate.
-- b) In all cases, if the discriminant controls a variant and the
-- variant has no others_choice, Constraint_Error must be raised if
-- the predicate is violated, because there is no variant covered
-- by the illegal discriminant value.
-----------------------------------
-- Check_Predicated_Discriminant --
-----------------------------------
procedure Check_Predicated_Discriminant
(Val : Node_Id;
Discr : Entity_Id)
is
Typ : constant Entity_Id := Etype (Discr);
procedure Check_Missing_Others (V : Node_Id);
-- ???
--------------------------
-- Check_Missing_Others --
--------------------------
procedure Check_Missing_Others (V : Node_Id) is
Alt : Node_Id;
Choice : Node_Id;
Last_Var : Node_Id;
begin
Last_Var := Last_Non_Pragma (Variants (V));
Choice := First (Discrete_Choices (Last_Var));
-- An others_choice is added during expansion for gcc use, but
-- does not cover the illegality.
if Entity (Name (V)) = Discr then
if Present (Choice)
and then (Nkind (Choice) /= N_Others_Choice
or else not Comes_From_Source (Choice))
then
Check_Expression_Against_Static_Predicate (Val, Typ);
if not Is_Static_Expression (Val) then
Prepend_To (Res,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd => Make_Predicate_Call (Typ, Val)),
Reason => CE_Invalid_Data));
end if;
end if;
end if;
-- Check whether some nested variant is ruled by the predicated
-- discriminant.
Alt := First (Variants (V));
while Present (Alt) loop
if Nkind (Alt) = N_Variant
and then Present (Variant_Part (Component_List (Alt)))
then
Check_Missing_Others
(Variant_Part (Component_List (Alt)));
end if;
Next (Alt);
end loop;
end Check_Missing_Others;
-- Local variables
Def : Node_Id;
-- Start of processing for Check_Predicated_Discriminant
begin
if Ekind (Base_Type (Full_Type)) = E_Record_Type then
Def := Type_Definition (Parent (Base_Type (Full_Type)));
else
return;
end if;
if Policy_In_Effect (Name_Assert) = Name_Check
and then not Predicates_Ignored (Etype (Discr))
then
Prepend_To (Res, Make_Predicate_Check (Typ, Val));
end if;
-- If discriminant controls a variant, verify that predicate is
-- obeyed or else an Others_Choice is present.
if Nkind (Def) = N_Record_Definition
and then Present (Variant_Part (Component_List (Def)))
and then Policy_In_Effect (Name_Assert) = Name_Ignore
then
Check_Missing_Others (Variant_Part (Component_List (Def)));
end if;
end Check_Predicated_Discriminant;
-- Local variables
Arg : Node_Id;
Args : List_Id;
Decls : List_Id;
@ -1294,11 +1405,12 @@ package body Exp_Ch3 is
Discr : Entity_Id;
First_Arg : Node_Id;
Full_Init_Type : Entity_Id;
Full_Type : Entity_Id;
Init_Call : Node_Id;
Init_Type : Entity_Id;
Proc : Entity_Id;
-- Start of processing for Build_Initialization_Call
begin
pragma Assert (Constructor_Ref = Empty
or else Is_CPP_Constructor_Call (Constructor_Ref));
@ -1490,14 +1602,10 @@ package body Exp_Ch3 is
-- of the discriminant, insert it ahead of the call.
Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
end if;
if Has_Predicates (Etype (Discr))
and then not Predicate_Checks_Suppressed (Empty)
and then not Predicates_Ignored (Etype (Discr))
then
Prepend_To (Res,
Make_Predicate_Check (Etype (Discr), Arg));
end if;
if Has_Predicates (Etype (Discr)) then
Check_Predicated_Discriminant (Arg, Discr);
end if;
end if;

127
gcc/ada/exp_ch7.adb
View File

@ -3605,60 +3605,6 @@ package body Exp_Ch7 is
Produced_Check := True;
end if;
-- In a rare case the designated type of an access component may
-- have an invariant. In this case verify the dereference of the
-- component.
if Is_Access_Type (Comp_Typ)
and then Has_Invariants (Designated_Type (Comp_Typ))
then
Proc_Id :=
Invariant_Procedure (Base_Type (Designated_Type (Comp_Typ)));
-- The designated type should have an invariant procedure if it
-- has invariants of its own or inherits class-wide invariants
-- from parent or interface types.
pragma Assert (Present (Proc_Id));
-- Generate:
-- if _object (<Indexes>) /= null then
-- <Desig_Comp_Typ>Invariant (_object (<Indices>).all);
-- end if;
-- Note that the invariant procedure may have a null body if
-- assertions are disabled or Assertion_Polity Ignore is in
-- effect.
if not Has_Null_Body (Proc_Id) then
Append_New_To (Comp_Checks,
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Obj_Id, Loc),
Expressions => New_Copy_List (Indices)),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (Obj_Id, Loc),
Expressions =>
New_Copy_List (Indices))))))));
end if;
Produced_Check := True;
end if;
end Process_Array_Component;
---------------------------
@ -4001,65 +3947,6 @@ package body Exp_Ch7 is
Produced_Component_Check := True;
end if;
-- In a rare case the designated type of an access component may
-- have a invariant. In this case verify the dereference of the
-- component.
if Is_Access_Type (Comp_Typ)
and then Has_Invariants (Designated_Type (Comp_Typ))
then
Proc_Id :=
Invariant_Procedure (Base_Type (Designated_Type (Comp_Typ)));
-- The designated type should have an invariant procedure if it
-- has invariants of its own or inherits class-wide invariants
-- from parent or interface types.
pragma Assert (Present (Proc_Id));
-- Generate:
-- if T (_object).<Comp_Id> /= null then
-- <Desig_Comp_Typ>Invariant (T (_object).<Comp_Id>.all);
-- end if;
-- Note that the invariant procedure may have a null body if
-- assertions are disabled or Assertion_Polity Ignore is in
-- effect.
if not Has_Null_Body (Proc_Id) then
Append_New_To (Comp_Checks,
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To
(T, New_Occurrence_Of (Obj_Id, Loc)),
Selector_Name =>
New_Occurrence_Of (Comp_Id, Loc)),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To
(T, New_Occurrence_Of (Obj_Id, Loc)),
Selector_Name =>
New_Occurrence_Of (Comp_Id, Loc))))))));
end if;
Produced_Check := True;
Produced_Component_Check := True;
end if;
if Produced_Component_Check and then Has_Unchecked_Union (T) then
Error_Msg_NE
("invariants cannot be checked on components of "
@ -4525,15 +4412,10 @@ package body Exp_Ch7 is
pragma Assert (Has_Invariants (Work_Typ));
-- ??? invariants of class-wide types are not properly implemented
if Is_Class_Wide_Type (Work_Typ) then
return;
-- Nothing to do for interface types as their class-wide invariants are
-- inherited by implementing types.
elsif Is_Interface (Work_Typ) then
if Is_Interface (Work_Typ) then
return;
end if;
@ -4849,15 +4731,10 @@ package body Exp_Ch7 is
pragma Assert (Has_Invariants (Work_Typ));
-- ??? invariants of class-wide types are not properly implemented
if Is_Class_Wide_Type (Work_Typ) then
return;
-- Nothing to do for interface types as their class-wide invariants are
-- inherited by implementing types.
elsif Is_Interface (Work_Typ) then
if Is_Interface (Work_Typ) then
return;
-- Nothing to do if the type already has a "partial" invariant procedure

14
gcc/ada/freeze.adb
View File

@ -2377,12 +2377,7 @@ package body Freeze is
-- The array type requires its own invariant procedure in order to
-- verify the component invariant over all elements.
if Has_Invariants (Component_Type (Arr))
or else
(Is_Access_Type (Component_Type (Arr))
and then Has_Invariants
(Designated_Type (Component_Type (Arr))))
then
if Has_Invariants (Component_Type (Arr)) then
Set_Has_Own_Invariants (Arr);
-- The array type is an implementation base type. Propagate the
@ -4305,12 +4300,7 @@ package body Freeze is
-- parent class-wide invariants are always inherited.
if Comes_From_Source (Comp)
and then
(Has_Invariants (Etype (Comp))
or else
(Is_Access_Type (Etype (Comp))
and then Has_Invariants
(Designated_Type (Etype (Comp)))))
and then Has_Invariants (Etype (Comp))
then
Set_Has_Own_Invariants (Rec);
end if;

49
gcc/ada/gnat1drv.adb
View File

@ -521,28 +521,35 @@ procedure Gnat1drv is
Targparm.Frontend_Layout_On_Target := True;
end if;
-- Set and check exception mechanism
-- Set and check exception mechanism. This is only meaningful when
-- compiling, and in particular not meaningful for special modes used
-- for program analysis rather than compilation: ASIS mode, CodePeer
-- mode and GNATprove mode.
case Targparm.Frontend_Exceptions_On_Target is
when True =>
case Targparm.ZCX_By_Default_On_Target is
when True =>
Write_Line
("Run-time library configured incorrectly");
Write_Line
("(requesting support for Frontend ZCX exceptions)");
raise Unrecoverable_Error;
when False =>
Exception_Mechanism := Front_End_SJLJ;
end case;
when False =>
case Targparm.ZCX_By_Default_On_Target is
when True =>
Exception_Mechanism := Back_End_ZCX;
when False =>
Exception_Mechanism := Back_End_SJLJ;
end case;
end case;
if Operating_Mode = Generate_Code
and then not (ASIS_Mode or CodePeer_Mode or GNATprove_Mode)
then
case Targparm.Frontend_Exceptions_On_Target is
when True =>
case Targparm.ZCX_By_Default_On_Target is
when True =>
Write_Line
("Run-time library configured incorrectly");
Write_Line
("(requesting support for Frontend ZCX exceptions)");
raise Unrecoverable_Error;
when False =>
Exception_Mechanism := Front_End_SJLJ;
end case;
when False =>
case Targparm.ZCX_By_Default_On_Target is
when True =>
Exception_Mechanism := Back_End_ZCX;
when False =>
Exception_Mechanism := Back_End_SJLJ;
end case;
end case;
end if;
-- Set proper status for overflow check mechanism

18
gcc/ada/sem_attr.adb
View File

@ -4465,7 +4465,17 @@ package body Sem_Attr is
-- purpose if they appear in an appropriate location in a loop,
-- which was already checked by the top level pragma circuit).
if No (Enclosing_Pragma) then
-- Loop_Entry also denotes a value and as such can appear within an
-- expression that is an argument for another loop aspect. In that
-- case it will have been expanded into the corresponding assignment.
if Expander_Active
and then Nkind (Parent (N)) = N_Assignment_Statement
and then not Comes_From_Source (Parent (N))
then
null;
elsif No (Enclosing_Pragma) then
Error_Attr ("attribute% must appear within appropriate pragma", N);
end if;
@ -4519,7 +4529,9 @@ package body Sem_Attr is
-- early transformation also avoids the generation of a useless loop
-- entry constant.
if Is_Ignored (Enclosing_Pragma) then
if Present (Enclosing_Pragma)
and then Is_Ignored (Enclosing_Pragma)
then
Rewrite (N, Relocate_Node (P));
Preanalyze_And_Resolve (N);
@ -11039,7 +11051,7 @@ package body Sem_Attr is
if Is_Entity_Name (P)
and then (Attr_Id = Attribute_Unrestricted_Access
or else Is_Subprogram (Entity (P)))
or else Is_Subprogram (Entity (P)))
then
Set_Address_Taken (Entity (P));
end if;

6
gcc/ada/sem_ch3.adb
View File

@ -18307,7 +18307,8 @@ package body Sem_Ch3 is
Set_Freeze_Node (CW_Type, Empty);
-- Customize the class-wide type: It has no prim. op., it cannot be
-- abstract and its Etype points back to the specific root type.
-- abstract, its Etype points back to the specific root type, and it
-- cannot have any invariants.
Set_Ekind (CW_Type, E_Class_Wide_Type);
Set_Is_Tagged_Type (CW_Type, True);
@ -18316,6 +18317,9 @@ package body Sem_Ch3 is
Set_Is_Constrained (CW_Type, False);
Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
Set_Default_SSO (CW_Type);
Set_Has_Inheritable_Invariants (CW_Type, False);
Set_Has_Inherited_Invariants (CW_Type, False);
Set_Has_Own_Invariants (CW_Type, False);
if Ekind (T) = E_Class_Wide_Subtype then
Set_Etype (CW_Type, Etype (Base_Type (T)));

15
gcc/ada/sem_util.adb
View File

@ -7572,7 +7572,14 @@ package body Sem_Util is
end loop Find_Discrete_Value;
end Search_For_Discriminant_Value;
if No (Variant) then
-- The case statement must include a variant that corresponds to the
-- value of the discriminant, unless the discriminant type has a
-- static predicate. In that case the absence of an others_choice that
-- would cover this value becomes a run-time error (3.8,1 (21.1/2)).
if No (Variant)
and then not Has_Static_Predicate (Etype (Discrim_Name))
then
Error_Msg_NE
("value of discriminant & is out of range", Discrim_Value, Discrim);
Report_Errors := True;
@ -7583,8 +7590,10 @@ package body Sem_Util is
-- components to the Into list. The nested components are part of
-- the same record type.
Gather_Components
(Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
if Present (Variant) then
Gather_Components
(Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
end if;
end Gather_Components;
------------------------