From e666e744789bce7e018bafd8893bac3fa27903d8 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Fri, 6 Jan 2017 12:04:33 +0000 Subject: [PATCH] exp_ch3.adb (Build_Initialization_Call): Apply predicate check to default discriminant value if checks are enabled. 2017-01-06 Ed Schonberg * exp_ch3.adb (Build_Initialization_Call): Apply predicate check to default discriminant value if checks are enabled. (Build_Assignment): If type of component has static predicate, apply check to its default value, if any. From-SVN: r244147 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/exp_ch3.adb | 22 ++++++++++++++++++++++ 2 files changed, 29 insertions(+) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3be774d8172..ad4f3ca647f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2017-01-06 Ed Schonberg + + * exp_ch3.adb (Build_Initialization_Call): Apply predicate + check to default discriminant value if checks are enabled. + (Build_Assignment): If type of component has static predicate, + apply check to its default value, if any. + 2017-01-06 Patrick Bernardi * aspect.adb, aspect.ads: Added new aspect Secondary_Stack_Size. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index ae2ed500f9a..e617c0540f8 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1485,8 +1485,18 @@ package body Exp_Ch3 is -- The constraints come from the discriminant default exps, -- they must be reevaluated, so we use New_Copy_Tree but we -- ensure the proper Sloc (for any embedded calls). + -- In addtion, if a predicate check is needed on the value + -- of the discriminant, insert it ahead of the call. Arg := New_Copy_Tree (Arg, New_Sloc => Loc); + + 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; end if; end if; @@ -1730,6 +1740,18 @@ package body Exp_Ch3 is Typ => Etype (Id))); end if; + -- If a component type has a predicate, add check to the component + -- assignment. Discriminants are hnndled at the point of the call, + -- which provides for a better error message. + + if Comes_From_Source (Exp) + and then Has_Predicates (Typ) + and then not Predicate_Checks_Suppressed (Empty) + and then not Predicates_Ignored (Typ) + then + Append (Make_Predicate_Check (Typ, Exp), Res); + end if; + return Res; exception -- 2.30.2