exp_ch4.adb (Expand_N_Type_Conversion): Minor code reformatting.

2008-05-26  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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

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;