diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 72 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 6 |
7 files changed, 139 insertions, 21 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e16a9be138f..cacf87c9bcd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2009-07-20 Javier Miranda <miranda@adacore.com> + + * sem_util.ads, sem_util.adb (Check_Dynamically_Tagged_Expression): New + subprogram. + * sem_aggr.adb (Resolve_Array_Aggregate): Check incorrect use of + dynamically tagged expression. + * sem_ch3.adb (Analyze_Object_Declaration): Call new routine that + factorizes code. + * sem_ch6.adb (Analyze_Function_Return, Process_Formals): Ditto. + * sem_ch8.adb (Analyze_Object_Renaming): Ditto. + 2009-07-20 Arnaud Charlet <charlet@adacore.com> * gnat1drv.adb (Gnat1drv): Set operating mode to Generate_Code when diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 9bff18efb9f..b7ac8f77565 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -28,6 +28,7 @@ with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; +with Expander; use Expander; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; @@ -1759,6 +1760,42 @@ package body Sem_Aggr is Single_Elmt => Single_Choice) then return Failure; + + -- Check incorrect use of dynamically tagged expression + + -- We differentiate here two cases because the expression may + -- not be decorated. For example, the analysis and resolution + -- of the expression associated with the others choice will + -- be done later with the full aggregate. In such case we + -- duplicate the expression tree to analyze the copy and + -- perform the required check. + + elsif not Present (Etype (Expression (Assoc))) then + declare + Save_Analysis : constant Boolean := Full_Analysis; + Expr : constant Node_Id := + New_Copy_Tree (Expression (Assoc)); + + begin + Expander_Mode_Save_And_Set (False); + Full_Analysis := False; + Analyze (Expr); + Full_Analysis := Save_Analysis; + Expander_Mode_Restore; + + if Is_Tagged_Type (Etype (Expr)) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => Component_Type (Etype (N)), + Related_Nod => N); + end if; + end; + + elsif Is_Tagged_Type (Etype (Expression (Assoc))) then + Check_Dynamically_Tagged_Expression + (Expr => Expression (Assoc), + Typ => Component_Type (Etype (N)), + Related_Nod => N); end if; Next (Assoc); @@ -1992,6 +2029,15 @@ package body Sem_Aggr is return Failure; end if; + -- Check incorrect use of dynamically tagged expression + + if Is_Tagged_Type (Etype (Expr)) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => Component_Type (Etype (N)), + Related_Nod => N); + end if; + Next (Expr); end loop; @@ -2021,6 +2067,32 @@ package body Sem_Aggr is Single_Elmt => False) then return Failure; + + -- Check incorrect use of dynamically tagged expression. The + -- expression of the others choice has not been resolved yet. + -- In order to diagnose the semantic error we create a duplicate + -- tree to analyze it and perform the check. + + else + declare + Save_Analysis : constant Boolean := Full_Analysis; + Expr : constant Node_Id := + New_Copy_Tree (Expression (Assoc)); + + begin + Expander_Mode_Save_And_Set (False); + Full_Analysis := False; + Analyze (Expr); + Full_Analysis := Save_Analysis; + Expander_Mode_Restore; + + if Is_Tagged_Type (Etype (Expr)) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => Component_Type (Etype (N)), + Related_Nod => N); + end if; + end; end if; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2050954cbe3..4efc72777ae 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2608,16 +2608,13 @@ package body Sem_Ch3 is end if; end if; - -- Check incorrect use of dynamically tagged expressions. Note - -- the use of Is_Tagged_Type (T) which seems redundant but is in - -- fact important to avoid spurious errors due to expanded code - -- for dispatching functions over an anonymous access type + -- Check incorrect use of dynamically tagged expressions. - if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E)) - and then Is_Tagged_Type (T) - and then not Is_Class_Wide_Type (T) - then - Error_Msg_N ("dynamically tagged expression not allowed!", E); + if Is_Tagged_Type (T) then + Check_Dynamically_Tagged_Expression + (Expr => E, + Typ => T, + Related_Nod => N); end if; Apply_Scalar_Range_Check (E, T); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 9de012f5db7..56a28607eb2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -749,12 +749,13 @@ package body Sem_Ch6 is end if; end if; - if (Is_Class_Wide_Type (Etype (Expr)) - or else Is_Dynamically_Tagged (Expr)) - and then not Is_Class_Wide_Type (R_Type) - then - Error_Msg_N - ("dynamically tagged expression not allowed!", Expr); + -- Check incorrect use of dynamically tagged expression + + if Is_Tagged_Type (R_Type) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => R_Type, + Related_Nod => N); end if; -- ??? A real run-time accessibility check is needed in cases @@ -8084,6 +8085,15 @@ package body Sem_Ch6 is Error_Msg_N ("access to class-wide expression not allowed here", Default); end if; + + -- Check incorrect use of dynamically tagged expressions + + if Is_Tagged_Type (Formal_Type) then + Check_Dynamically_Tagged_Expression + (Expr => Default, + Typ => Formal_Type, + Related_Nod => Default); + end if; end if; -- Ada 2005 (AI-231): Static checks diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index afb0d4233ec..005dedfbc25 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -754,12 +754,11 @@ package body Sem_Ch8 is -- cases where the renamed object is a dynamically tagged access -- result, such as occurs in certain expansions. - if (Is_Class_Wide_Type (Etype (Nam)) - or else (Is_Dynamically_Tagged (Nam) - and then not Is_Access_Type (T))) - and then not Is_Class_Wide_Type (T) - then - Error_Msg_N ("dynamically tagged expression not allowed!", Nam); + if Is_Tagged_Type (T) then + Check_Dynamically_Tagged_Expression + (Expr => Nam, + Typ => T, + Related_Nod => N); end if; -- Ada 2005 (AI-230/AI-254): Access renaming diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7a0108511fb..3e3c03a0f10 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -47,6 +47,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Attr; use Sem_Attr; with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -1032,6 +1033,28 @@ 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)); + + if Comes_From_Source (Related_Nod) + 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 -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 44d6c3ef5be..aa3958f8b4f 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -125,6 +125,12 @@ package Sem_Util is -- not necessarily mean that CE could be raised, but a response of True -- means that for sure CE cannot be raised. + procedure Check_Dynamically_Tagged_Expression + (Expr : Node_Id; + Typ : Entity_Id; + Related_Nod : Node_Id); + -- Check wrong use of dynamically tagged expression + 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 |