From: Ed Schonberg Date: Fri, 30 Jan 2015 09:29:51 +0000 (+0000) Subject: sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity or a function call... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b6dd03dd9c48470246b4b47e7471b2cf99c65737;p=gcc.git sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity or a function call, return True if type is class-wide. 2015-01-30 Ed Schonberg * sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity or a function call, return True if type is class-wide. * sem_res.adb (Resolve_Case_Expression, Resolve_If_Expression); Apply RM 4.5.7 (17/3): all or none of the dependent expression of a conditional expression must be dynamically tagged. From-SVN: r220276 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index be0188ddad7..a67b7d37ded 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2015-01-30 Ed Schonberg + + * sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity + or a function call, return True if type is class-wide. + * sem_res.adb (Resolve_Case_Expression, Resolve_If_Expression); + Apply RM 4.5.7 (17/3): all or none of the dependent expression + of a conditional expression must be dynamically tagged. + 2015-01-30 Ed Schonberg * sem_ch6.adb (Analyze_Function_Return): In an extended return diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index a915ab05e77..0a9bfba5942 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -562,6 +562,12 @@ package body Sem_Disp is then null; + elsif Ekind (Current_Scope) = E_Function + and then Nkind (Unit_Declaration_Node (Current_Scope)) + = N_Generic_Subprogram_Declaration + then + null; + else -- We need to determine whether the context of the call -- provides a tag to make the call dispatching. This requires @@ -2162,8 +2168,24 @@ package body Sem_Disp is begin if Nkind (N) = N_Error then return False; + + elsif Present (Find_Controlling_Arg (N)) then + return True; + + -- Special cases : entities, and calls that dispatch on result. + + elsif Is_Entity_Name (N) then + return Is_Class_Wide_Type (Etype (N)); + + elsif Nkind (N) = N_Function_Call + and then Is_Class_Wide_Type (Etype (N)) + then + return True; + + -- Otherwise check whether call has controlling argument. + else - return Find_Controlling_Arg (N) /= Empty; + return False; end if; end Is_Dynamically_Tagged; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 82890810a48..5096c6a6264 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6416,7 +6416,8 @@ package body Sem_Res is ----------------------------- procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is - Alt : Node_Id; + Alt : Node_Id; + Is_Dyn : Boolean; begin Alt := First (Alternatives (N)); @@ -6425,6 +6426,23 @@ package body Sem_Res is Next (Alt); end loop; + -- Apply RM 4.5.7 (17/3): whether the expression is statically or + -- dynamically tagged must be known statically. + + if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then + Alt := First (Alternatives (N)); + Is_Dyn := Is_Dynamically_Tagged (Expression (Alt)); + + while Present (Alt) loop + if Is_Dynamically_Tagged (Expression (Alt)) /= Is_Dyn then + Error_Msg_N ("all or none of the dependent expressions " + & "can be dynamically tagged", N); + end if; + + Next (Alt); + end loop; + end if; + Set_Etype (N, Typ); Eval_Case_Expression (N); end Resolve_Case_Expression; @@ -8061,11 +8079,20 @@ package body Sem_Res is Resolve (Else_Expr, Typ); Else_Typ := Etype (Else_Expr); - if Is_Scalar_Type (Else_Typ) - and then Else_Typ /= Typ - then + if Is_Scalar_Type (Else_Typ) and then Else_Typ /= Typ then Rewrite (Else_Expr, Convert_To (Typ, Else_Expr)); Analyze_And_Resolve (Else_Expr, Typ); + + -- Apply RM 4.5.7 (17/3): whether the expression is statically or + -- dynamically tagged must be known statically. + + elsif Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then + if Is_Dynamically_Tagged (Then_Expr) /= + Is_Dynamically_Tagged (Else_Expr) + then + Error_Msg_N ("all or none of the dependent expressions " + & "can be dynamically tagged", N); + end if; end if; -- If no ELSE expression is present, root type must be Standard.Boolean @@ -8232,10 +8259,10 @@ package body Sem_Res is (Entity (Prefix (N))))) and then not Is_Atomic (Component_Type (Array_Type)) then - Error_Msg_N ("??access to non-atomic component of atomic array", - Prefix (N)); - Error_Msg_N ("??\may cause unexpected accesses to atomic object", - Prefix (N)); + Error_Msg_N + ("??access to non-atomic component of atomic array", Prefix (N)); + Error_Msg_N + ("??\may cause unexpected accesses to atomic object", Prefix (N)); end if; end Resolve_Indexed_Component; @@ -8263,9 +8290,14 @@ package body Sem_Res is -- If the operand is a literal, it cannot be the expression in a -- conversion. Use a qualified expression instead. + --------------------- + -- Convert_Operand -- + --------------------- + function Convert_Operand (Opnd : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Opnd); Res : Node_Id; + begin if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then Res := @@ -8309,8 +8341,6 @@ package body Sem_Res is or else Is_Private_Type (Etype (Right_Opnd (N))) then Arg1 := Convert_Operand (Left_Opnd (N)); - -- Unchecked_Convert_To (Btyp, Left_Opnd (N)); - -- What on earth is this commented out fragment of code??? if Nkind (N) = N_Op_Expon then Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));