+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,
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;
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));
-- 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;
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;
---------------------------
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 "
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;
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
-- 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
-- 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;
Targparm.Frontend_Layout_On_Target := True;
end if;
- -- Set and check exception mechanism
-
- 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;
+ -- 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.
+
+ 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
-- 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;
-- 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);
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;
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);
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)));
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;
-- 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;
------------------------
projects / gcc.git / commitdiff