From 45c8b94ba4eb9acfa5c245c14d7c2b7554477434 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Wed, 26 Sep 2007 12:46:22 +0200 Subject: [PATCH] sem_ch4.adb (Analyze_Qualified_Expression): Apply name resolution rule for qualified expressions properly... 2007-09-26 Ed Schonberg * sem_ch4.adb (Analyze_Qualified_Expression): Apply name resolution rule for qualified expressions properly, to detect improper conversions and resolve some cases of overloading. From-SVN: r128803 --- gcc/ada/sem_ch4.adb | 64 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 54 insertions(+), 10 deletions(-) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index f72ac88886f..d2a12e6c5c6 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -354,11 +354,15 @@ package body Sem_Ch4 is Set_Etype (Acc_Type, Acc_Type); Init_Size_Align (Acc_Type); Find_Type (Subtype_Mark (E)); - Type_Id := Entity (Subtype_Mark (E)); - Check_Fully_Declared (Type_Id, N); + + -- Analyze the qualified expression, and apply the name resolution + -- rule given in 4.7 (3). + + Analyze (E); + Type_Id := Etype (E); Set_Directly_Designated_Type (Acc_Type, Type_Id); - Analyze_And_Resolve (Expression (E), Type_Id); + Resolve (Expression (E), Type_Id); if Is_Limited_Type (Type_Id) and then Comes_From_Source (N) @@ -373,11 +377,12 @@ package body Sem_Ch4 is -- A qualified expression requires an exact match of the type, -- class-wide matching is not allowed. - if Is_Class_Wide_Type (Type_Id) - and then Base_Type (Etype (Expression (E))) /= Base_Type (Type_Id) - then - Wrong_Type (Expression (E), Type_Id); - end if; + -- if Is_Class_Wide_Type (Type_Id) + -- and then Base_Type + -- (Etype (Expression (E))) /= Base_Type (Type_Id) + -- then + -- Wrong_Type (Expression (E), Type_Id); + -- end if; Check_Non_Static_Context (Expression (E)); @@ -924,6 +929,8 @@ package body Sem_Ch4 is -- Check for not-yet-implemented cases of AI-318. We only need to check -- for inherently limited types, because other limited types will be -- returned by copy, which works just fine. + -- If the context is an attribute reference 'Class, this is really a + -- type conversion, which is illegal, and will be caught elsewhere. if Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L @@ -931,7 +938,9 @@ package body Sem_Ch4 is and then (Nkind (Parent (N)) = N_Selected_Component or else Nkind (Parent (N)) = N_Indexed_Component or else Nkind (Parent (N)) = N_Slice - or else Nkind (Parent (N)) = N_Attribute_Reference) + or else + (Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) /= Name_Class)) then Error_Msg_N ("(Ada 2005) limited function call in this context" & " is not yet implemented", N); @@ -2520,19 +2529,54 @@ package body Sem_Ch4 is procedure Analyze_Qualified_Expression (N : Node_Id) is Mark : constant Entity_Id := Subtype_Mark (N); + Expr : constant Node_Id := Expression (N); + I : Interp_Index; + It : Interp; T : Entity_Id; begin + Analyze_Expression (Expr); + Set_Etype (N, Any_Type); Find_Type (Mark); T := Entity (Mark); + Set_Etype (N, T); if T = Any_Type then return; end if; Check_Fully_Declared (T, N); - Analyze_Expression (Expression (N)); + + -- If expected type is class-wide, check for exact match before + -- expansion, because if the expression is a dispatching call it + -- may be rewritten as explicit dereference with class-wide result. + -- If expression is overloaded, retain only interpretations that + -- will yield exact matches. + + if Is_Class_Wide_Type (T) then + if not Is_Overloaded (Expr) then + if Base_Type (Etype (Expr)) /= Base_Type (T) then + if Nkind (Expr) = N_Aggregate then + Error_Msg_N ("type of aggregate cannot be class-wide", Expr); + else + Wrong_Type (Expr, T); + end if; + end if; + + else + Get_First_Interp (Expr, I, It); + + while Present (It.Nam) loop + if Base_Type (It.Typ) /= Base_Type (T) then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end if; + Set_Etype (N, T); end Analyze_Qualified_Expression; -- 2.30.2