diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2013-04-25 12:51:19 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2013-04-25 12:51:19 +0200 |
commit | f197d2f29355314ccbf0a816f3ad20c20b506bef (patch) | |
tree | 6f7c96cd6779934fc8294e71c105f19678321d2f /gcc/ada | |
parent | bbee5cc4b054ad87d3200f6d17e425040fbc50f6 (diff) | |
download | gcc-f197d2f29355314ccbf0a816f3ad20c20b506bef.zip gcc-f197d2f29355314ccbf0a816f3ad20c20b506bef.tar.gz gcc-f197d2f29355314ccbf0a816f3ad20c20b506bef.tar.bz2 |
[multiple changes]
2013-04-25 Arnaud Charlet <charlet@adacore.com>
* par-prag.adb: Fix typo.
2013-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb (Apply_Predicate_Check): If the type has a static
predicate and the expression is also static, check whether the
expression satisfies the predicate.
* sem_ch3.adb (Analyze_Object_Declaration): If the type has a
static predicate and the expression is also static, see if the
expression satisfies the predicate.
* sem_util.adb: Alphabetize several routines.
(Check_Expression_Against_Static_Predicate): New routine.
* sem_util.ads (Check_Expression_Against_Static_Predicate): New routine.
From-SVN: r198296
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 16 | ||||
-rw-r--r-- | gcc/ada/checks.adb | 27 | ||||
-rw-r--r-- | gcc/ada/par-prag.adb | 2 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 17 | ||||
-rw-r--r-- | gcc/ada/sem_util.adb | 181 | ||||
-rw-r--r-- | gcc/ada/sem_util.ads | 8 |
6 files changed, 149 insertions, 102 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3c3d7db..69141c3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2013-04-25 Arnaud Charlet <charlet@adacore.com> + + * par-prag.adb: Fix typo. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Apply_Predicate_Check): If the type has a static + predicate and the expression is also static, check whether the + expression satisfies the predicate. + * sem_ch3.adb (Analyze_Object_Declaration): If the type has a + static predicate and the expression is also static, see if the + expression satisfies the predicate. + * sem_util.adb: Alphabetize several routines. + (Check_Expression_Against_Static_Predicate): New routine. + * sem_util.ads (Check_Expression_Against_Static_Predicate): New routine. + 2013-04-25 Robert Dewar <dewar@adacore.com> * gnat_rm.texi: Document Reason argument for pragma Warnings. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 3cb1f95..5a5b7d1 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2502,29 +2502,10 @@ package body Checks is -- Here for normal case of predicate active else - -- If the predicate is a static predicate and the operand is - -- static, the predicate must be evaluated statically. If the - -- evaluation fails this is a static constraint error. This check - -- is disabled in -gnatc mode, because the compiler is incapable - -- of evaluating static expressions in that case. Note that when - -- inherited predicates are involved, a type may have both static - -- and dynamic forms. Check the presence of a dynamic predicate - -- aspect. - - if Is_OK_Static_Expression (N) - and then Present (Static_Predicate (Typ)) - and then not Has_Dynamic_Predicate_Aspect (Typ) - then - if Operating_Mode < Generate_Code - or else Eval_Static_Predicate_Check (N, Typ) - then - return; - else - Error_Msg_NE - ("static expression fails static predicate check on&", - N, Typ); - end if; - end if; + -- If the type has a static predicate and the expression is also + -- static, see if the expression satisfies the predicate. + + Check_Expression_Against_Static_Predicate (N, Typ); Insert_Action (N, Make_Predicate_Check (Typ, Duplicate_Subexpr (N))); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index de26209..3587dff 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -17,7 +17,7 @@ -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- --- War -- +-- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index bd0a519..0817773 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3260,11 +3260,11 @@ package body Sem_Ch3 is end if; end if; - -- Deal with predicate check before we start to do major rewriting. - -- it is OK to initialize and then check the initialized value, since - -- the object goes out of scope if we get a predicate failure. Note - -- that we do this in the analyzer and not the expander because the - -- analyzer does some substantial rewriting in some cases. + -- Deal with predicate check before we start to do major rewriting. It + -- is OK to initialize and then check the initialized value, since the + -- object goes out of scope if we get a predicate failure. Note that we + -- do this in the analyzer and not the expander because the analyzer + -- does some substantial rewriting in some cases. -- We need a predicate check if the type has predicates, and if either -- there is an initializing expression, or for default initialization @@ -3277,6 +3277,13 @@ package body Sem_Ch3 is or else Is_Partially_Initialized_Type (T, Include_Implicit => False)) then + -- If the type has a static predicate and the expression is also + -- static, see if the expression satisfies the predicate. + + if Present (E) then + Check_Expression_Against_Static_Predicate (E, T); + end if; + Insert_After (N, Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ab68c39..bc1f3fb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1265,6 +1265,114 @@ package body Sem_Util is end if; end Cannot_Raise_Constraint_Error; + ----------------------------------------- + -- Check_Dynamically_Tagged_Expression -- + ----------------------------------------- + + procedure Check_Dynamically_Tagged_Expression + (Expr : Node_Id; + Typ : Entity_Id; + Related_Nod : Node_Id) + is + begin + pragma Assert (Is_Tagged_Type (Typ)); + + -- In order to avoid spurious errors when analyzing the expanded code, + -- this check is done only for nodes that come from source and for + -- actuals of generic instantiations. + + if (Comes_From_Source (Related_Nod) + or else In_Generic_Actual (Expr)) + and then (Is_Class_Wide_Type (Etype (Expr)) + or else Is_Dynamically_Tagged (Expr)) + and then Is_Tagged_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + then + Error_Msg_N ("dynamically tagged expression not allowed!", Expr); + end if; + end Check_Dynamically_Tagged_Expression; + + ----------------------------------------------- + -- Check_Expression_Against_Static_Predicate -- + ----------------------------------------------- + + procedure Check_Expression_Against_Static_Predicate + (Expr : Node_Id; + Typ : Entity_Id) + is + begin + -- When both the predicate and the expression are static, evaluate the + -- check at compile time. A type becomes non-static when it has aspect + -- Dynamic_Predicate. + + if Is_OK_Static_Expression (Expr) + and then Has_Predicates (Typ) + and then Present (Static_Predicate (Typ)) + and then not Has_Dynamic_Predicate_Aspect (Typ) + then + -- Either -gnatc is enabled or the expression is ok + + if Operating_Mode < Generate_Code + or else Eval_Static_Predicate_Check (Expr, Typ) + then + null; + + -- The expression is prohibited by the static predicate + + else + Error_Msg_NE + ("?static expression fails static predicate check on &", + Expr, Typ); + end if; + end if; + end Check_Expression_Against_Static_Predicate; + + -------------------------- + -- Check_Fully_Declared -- + -------------------------- + + procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is + begin + if Ekind (T) = E_Incomplete_Type then + + -- Ada 2005 (AI-50217): If the type is available through a limited + -- with_clause, verify that its full view has been analyzed. + + if From_With_Type (T) + and then Present (Non_Limited_View (T)) + and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type + then + -- The non-limited view is fully declared + null; + + else + Error_Msg_NE + ("premature usage of incomplete}", N, First_Subtype (T)); + end if; + + -- Need comments for these tests ??? + + elsif Has_Private_Component (T) + and then not Is_Generic_Type (Root_Type (T)) + and then not In_Spec_Expression + then + -- Special case: if T is the anonymous type created for a single + -- task or protected object, use the name of the source object. + + if Is_Concurrent_Type (T) + and then not Comes_From_Source (T) + and then Nkind (N) = N_Object_Declaration + then + Error_Msg_NE ("type of& has incomplete component", N, + Defining_Identifier (N)); + + else + Error_Msg_NE + ("premature usage of incomplete}", N, First_Subtype (T)); + end if; + end if; + end Check_Fully_Declared; + ------------------------------------- -- Check_Function_Writable_Actuals -- ------------------------------------- @@ -2016,79 +2124,6 @@ package body Sem_Util is end loop Outer; end Check_Later_Vs_Basic_Declarations; - ----------------------------------------- - -- Check_Dynamically_Tagged_Expression -- - ----------------------------------------- - - procedure Check_Dynamically_Tagged_Expression - (Expr : Node_Id; - Typ : Entity_Id; - Related_Nod : Node_Id) - is - begin - pragma Assert (Is_Tagged_Type (Typ)); - - -- In order to avoid spurious errors when analyzing the expanded code, - -- this check is done only for nodes that come from source and for - -- actuals of generic instantiations. - - if (Comes_From_Source (Related_Nod) - or else In_Generic_Actual (Expr)) - and then (Is_Class_Wide_Type (Etype (Expr)) - or else Is_Dynamically_Tagged (Expr)) - and then Is_Tagged_Type (Typ) - and then not Is_Class_Wide_Type (Typ) - then - Error_Msg_N ("dynamically tagged expression not allowed!", Expr); - end if; - end Check_Dynamically_Tagged_Expression; - - -------------------------- - -- Check_Fully_Declared -- - -------------------------- - - procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is - begin - if Ekind (T) = E_Incomplete_Type then - - -- Ada 2005 (AI-50217): If the type is available through a limited - -- with_clause, verify that its full view has been analyzed. - - if From_With_Type (T) - and then Present (Non_Limited_View (T)) - and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type - then - -- The non-limited view is fully declared - null; - - else - Error_Msg_NE - ("premature usage of incomplete}", N, First_Subtype (T)); - end if; - - -- Need comments for these tests ??? - - elsif Has_Private_Component (T) - and then not Is_Generic_Type (Root_Type (T)) - and then not In_Spec_Expression - then - -- Special case: if T is the anonymous type created for a single - -- task or protected object, use the name of the source object. - - if Is_Concurrent_Type (T) - and then not Comes_From_Source (T) - and then Nkind (N) = N_Object_Declaration - then - Error_Msg_NE ("type of& has incomplete component", N, - Defining_Identifier (N)); - - else - Error_Msg_NE - ("premature usage of incomplete}", N, First_Subtype (T)); - end if; - end if; - end Check_Fully_Declared; - ------------------------- -- Check_Nested_Access -- ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d6d1ecc..b5d1ed3 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -191,6 +191,14 @@ package Sem_Util is Related_Nod : Node_Id); -- Check wrong use of dynamically tagged expression + procedure Check_Expression_Against_Static_Predicate + (Expr : Node_Id; + Typ : Entity_Id); + -- Determine whether an arbitrary expression satisfies the static predicate + -- of a type. The routine does nothing if Expr is non-static or Typ lacks a + -- static predicate, otherwise it may emit a warning if the expression is + -- prohibited by the predicate. + procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); -- Verify that the full declaration of type T has been seen. If not, place -- error message on node N. Used in object declarations, type conversions |