Patchwork [Ada] Functions returning dispatching results

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 4, 2010, 1:38 p.m.
Message ID <20101004133843.GA8862@adacore.com>
Download mbox | patch
Permalink /patch/66652/
State New
Headers show

Comments

Arnaud Charlet - Oct. 4, 2010, 1:38 p.m.
This patch disables a tag check for an assignment statement where the left hand
side is an interface object. In this case the right hand side must only cover
the interface and the tags of both sides do not need to be compared at run time.

The following program should compile and execute silently.

package Types is
   type Root_Iface is interface;
   function Create (Element : Integer) return Root_Iface is abstract;

   package Pkg is
      type Parent is abstract tagged null record;

      type Child is new Parent and Root_Iface with record
         Element : Integer;
      end record;

      function Create (Element : Integer) return Child;

      Default : constant Child := (Element => 0);
   end Pkg;
end Types;
package body Types is
   package body Pkg is
      function Create (Element : Integer) return Child is
         Result : Child := Child'(Element => Element);
      begin
         return Result;
      end Create;
   end Pkg;
end Types;
with Types; use Types;
            use Types.Pkg;

procedure Main is
   My_Object : Root_Iface'Class := Default;
begin
   My_Object := Types.Create (10);
end Main;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-04  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch5.adb (Expand_N_Assignment_Statement): Do not generate a tag
	check when the target object is an interface since the expression of
	the right hand side must only cover the interface.

Patch

Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb	(revision 164906)
+++ exp_ch5.adb	(working copy)
@@ -1956,6 +1956,12 @@  package body Exp_Ch5 is
                   if Is_Class_Wide_Type (Typ)
                     and then Is_Tagged_Type (Typ)
                     and then Is_Tagged_Type (Underlying_Type (Etype (Rhs)))
+
+                    --   Do not generate a tag check when the target object is
+                    --   an interface since the expression of the right hand
+                    --   side must only cover the interface.
+
+                    and then not Is_Interface (Typ)
                   then
                      Append_To (L,
                        Make_Raise_Constraint_Error (Loc,