From: Hristian Kirtchev Date: Mon, 26 May 2008 12:45:19 +0000 (+0200) Subject: exp_ch4.adb (Expand_N_Type_Conversion): Minor code reformatting. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8cea7b648833d403a40ec9e8ce7ee97292e31c21;p=gcc.git exp_ch4.adb (Expand_N_Type_Conversion): Minor code reformatting. 2008-05-26 Hristian Kirtchev * exp_ch4.adb (Expand_N_Type_Conversion): Minor code reformatting. Generate a tag check when the result subtype of a function, defined by an access definition, designates a specific tagged type. (Make_Tag_Check): New routine. From-SVN: r135916 --- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0246516fcbf..1eb727392d9 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7583,79 +7583,151 @@ package body Exp_Ch4 is -- Otherwise, proceed with processing tagged conversion declare - Actual_Operand_Type : Entity_Id; - Actual_Target_Type : Entity_Id; + Actual_Op_Typ : Entity_Id; + Actual_Targ_Typ : Entity_Id; + Make_Conversion : Boolean := False; + Root_Op_Typ : Entity_Id; - Cond : Node_Id; + procedure Make_Tag_Check (Targ_Typ : Entity_Id); + -- Create a membership check to test whether Operand is a member + -- of Targ_Typ. If the original Target_Type is an access, include + -- a test for null value. The check is inserted at N. + + -------------------- + -- Make_Tag_Check -- + -------------------- + + procedure Make_Tag_Check (Targ_Typ : Entity_Id) is + Cond : Node_Id; + + begin + -- Generate: + -- [Constraint_Error + -- when Operand /= null + -- and then Operand.all not in Targ_Typ] + + if Is_Access_Type (Target_Type) then + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), + Right_Opnd => Make_Null (Loc)), + + Right_Opnd => + Make_Not_In (Loc, + Left_Opnd => + Make_Explicit_Dereference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Operand)), + Right_Opnd => New_Reference_To (Targ_Typ, Loc))); + + -- Generate: + -- [Constraint_Error when Operand not in Targ_Typ] + + else + Cond := + Make_Not_In (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), + Right_Opnd => New_Reference_To (Targ_Typ, Loc)); + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Tag_Check_Failed)); + end Make_Tag_Check; + + -- Start of processing begin if Is_Access_Type (Target_Type) then - Actual_Operand_Type := Designated_Type (Operand_Type); - Actual_Target_Type := Designated_Type (Target_Type); + Actual_Op_Typ := Designated_Type (Operand_Type); + Actual_Targ_Typ := Designated_Type (Target_Type); else - Actual_Operand_Type := Operand_Type; - Actual_Target_Type := Target_Type; + Actual_Op_Typ := Operand_Type; + Actual_Targ_Typ := Target_Type; end if; + Root_Op_Typ := Root_Type (Actual_Op_Typ); + -- Ada 2005 (AI-251): Handle interface type conversion - if Is_Interface (Actual_Operand_Type) then + if Is_Interface (Actual_Op_Typ) then Expand_Interface_Conversion (N, Is_Static => False); return; end if; - if Is_Class_Wide_Type (Actual_Operand_Type) - and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type - and then Is_Ancestor - (Root_Type (Actual_Operand_Type), - Actual_Target_Type) - and then not Tag_Checks_Suppressed (Actual_Target_Type) - then - -- Conversion is valid for any descendant of the target type + if not Tag_Checks_Suppressed (Actual_Targ_Typ) then - Actual_Target_Type := Class_Wide_Type (Actual_Target_Type); + -- Create a runtime tag check for a downward class-wide type + -- conversion. - if Is_Access_Type (Target_Type) then - Cond := - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ne (Loc, - Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), - Right_Opnd => Make_Null (Loc)), + if Is_Class_Wide_Type (Actual_Op_Typ) + and then Root_Op_Typ /= Actual_Targ_Typ + and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ) + then + Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); + Make_Conversion := True; + end if; - Right_Opnd => - Make_Not_In (Loc, - Left_Opnd => - Make_Explicit_Dereference (Loc, - Prefix => - Duplicate_Subexpr_No_Checks (Operand)), - Right_Opnd => - New_Reference_To (Actual_Target_Type, Loc))); + -- AI05-0073: If the result subtype of the function is defined + -- by an access_definition designating a specific tagged type + -- T, a check is made that the result value is null or the tag + -- of the object designated by the result value identifies T. + -- Constraint_Error is raised if this check fails. - else - Cond := - Make_Not_In (Loc, - Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), - Right_Opnd => - New_Reference_To (Actual_Target_Type, Loc)); + if Nkind (Parent (N)) = Sinfo.N_Return_Statement then + declare + Func : Entity_Id := Current_Scope; + Func_Typ : Entity_Id; + + begin + -- Climb the scope stack looking for the enclosing + -- function. + + while Present (Func) + and then Ekind (Func) /= E_Function + loop + Func := Scope (Func); + end loop; + + -- The function's return subtype must be defined using + -- an access definition. + + if Nkind (Result_Definition (Parent (Func))) = + N_Access_Definition + then + Func_Typ := Directly_Designated_Type (Etype (Func)); + + -- The return subtype denotes a specific tagged type, + -- in other words, a non class-wide type. + + if Is_Tagged_Type (Func_Typ) + and then not Is_Class_Wide_Type (Func_Typ) + then + Make_Tag_Check (Actual_Targ_Typ); + Make_Conversion := True; + end if; + end if; + end; end if; - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => Cond, - Reason => CE_Tag_Check_Failed)); + -- We have generated a tag check for either a class-wide type + -- conversion or for AI05-0073. - declare - Conv : Node_Id; - begin - Conv := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), - Expression => Relocate_Node (Expression (N))); - Rewrite (N, Conv); - Analyze_And_Resolve (N, Target_Type); - end; + if Make_Conversion then + declare + Conv : Node_Id; + begin + Conv := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Expression (N))); + Rewrite (N, Conv); + Analyze_And_Resolve (N, Target_Type); + end; + end if; end if; end;