Patchwork [Ada] Crash overriding the equality operator

login
register
mail settings
Submitter Arnaud Charlet
Date June 22, 2010, 4:57 p.m.
Message ID <20100622165721.GA14363@adacore.com>
Download mbox | patch
Permalink /patch/56531/
State New
Headers show

Comments

Arnaud Charlet - June 22, 2010, 4:57 p.m.
The compiler crashes processing a primitive that overrides the
equality operator of a tagged type by means of a function that
has a return statement that performs a dispatching call. The
following test now compiles silently.

package Alpha is
   type Object is abstract tagged null record;

   function "=" (L, R : in Object) return Boolean;
   function Equal (L, R : in Object) return Boolean is abstract;
end Alpha;

package body Alpha is
   function "=" (L, R : in Object) return Boolean is
   begin
      return Equal (Object'Class (L), Object'Class (R)); -- test
   end "=";
end Alpha;

Command: gcc -c -gnat05 alpha.adb

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

2010-06-22  Javier Miranda  <miranda@adacore.com>

	* einfo.ads, einfo.adb (Last_Formal): New synthesized attribute.
	* exp_util.adb (Find_Prim_Op): Use new attribute to locate the last
	formal of a primitive.
	* exp_disp.adb (Is_Predefined_Dispatching_Operation,
	 Is_Predefined_Dispatching_Alias): Use new attribute to locate the last
	formal of a primitive.
	* exp_cg.adb (Is_Predefined_Dispatching_Operation): Use new attribute
	to obtain the last formal of a primitive.

Patch

Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 161137)
+++ exp_util.adb	(working copy)
@@ -1670,7 +1670,7 @@  package body Exp_Util is
          exit when Chars (Op) = Name
            and then
              (Name /= Name_Op_Eq
-                or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op)));
+                or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
 
          Next_Elmt (Prim);
 
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 161200)
+++ einfo.adb	(working copy)
@@ -6209,6 +6209,36 @@  package body Einfo is
                and then Present (Related_Instance (Id)));
    end Is_Wrapper_Package;
 
+   -----------------
+   -- Last_Formal --
+   -----------------
+
+   function Last_Formal (Id : E) return E is
+      Formal : E;
+
+   begin
+      pragma Assert
+        (Is_Overloadable (Id)
+          or else Ekind_In (Id, E_Entry_Family,
+                                E_Subprogram_Body,
+                                E_Subprogram_Type));
+
+      if Ekind (Id) = E_Enumeration_Literal then
+         return Empty;
+
+      else
+         Formal := First_Formal (Id);
+
+         if Present (Formal) then
+            while Present (Next_Formal (Formal)) loop
+               Formal := Next_Formal (Formal);
+            end loop;
+         end if;
+
+         return Formal;
+      end if;
+   end Last_Formal;
+
    --------------------
    -- Next_Component --
    --------------------
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 161200)
+++ einfo.ads	(working copy)
@@ -2756,6 +2756,13 @@  package Einfo is
 --       Points to the last entry in the list of associated entities chained
 --       through the Next_Entity field. Empty if no entities are chained.
 
+--    Last_Formal (synthesized)
+--       Applies to subprograms and subprogram types, and also in entries
+--       and entry families. Returns last formal of the subprogram or entry.
+--       The formals are the first entities declared in a subprogram or in
+--       a subprogram type (the designated type of an Access_To_Subprogram
+--       definition) or in an entry.
+
 --    Limited_View (Node23)
 --       Present in non-generic package entities that are not instances. Bona
 --       fide package with the limited-view list through the first_entity and
@@ -4881,9 +4888,10 @@  package Einfo is
    --    Sec_Stack_Needed_For_Return         (Flag167)
    --    Uses_Sec_Stack                      (Flag95)
    --    Address_Clause                      (synth)
+   --    Entry_Index_Type                    (synth)
    --    First_Formal                        (synth)
    --    First_Formal_With_Extras            (synth)
-   --    Entry_Index_Type                    (synth)
+   --    Last_Formal                         (synth)
    --    Number_Formals                      (synth)
    --    Scope_Depth                         (synth)
 
@@ -5002,6 +5010,7 @@  package Einfo is
    --    Address_Clause                      (synth)
    --    First_Formal                        (synth)
    --    First_Formal_With_Extras            (synth)
+   --    Last_Formal                         (synth)
    --    Number_Formals                      (synth)
    --    Scope_Depth                         (synth)
 
@@ -5261,6 +5270,7 @@  package Einfo is
    --    Address_Clause                      (synth)
    --    First_Formal                        (synth)
    --    First_Formal_With_Extras            (synth)
+   --    Last_Formal                         (synth)
    --    Number_Formals                      (synth)
 
    --  E_Protected_Body
@@ -5385,6 +5395,7 @@  package Einfo is
    --    Directly_Designated_Type            (Node20)
    --    First_Formal                        (synth)
    --    First_Formal_With_Extras            (synth)
+   --    Last_Formal                         (synth)
    --    Number_Formals                      (synth)
    --    (plus type attributes)
 
@@ -6149,6 +6160,7 @@  package Einfo is
    function Is_Task_Interface                   (Id : E) return B;
    function Is_Task_Record_Type                 (Id : E) return B;
    function Is_Wrapper_Package                  (Id : E) return B;
+   function Last_Formal                         (Id : E) return E;
    function Next_Component                      (Id : E) return E;
    function Next_Component_Or_Discriminant      (Id : E) return E;
    function Next_Discriminant                   (Id : E) return E;
Index: exp_disp.adb
===================================================================
--- exp_disp.adb	(revision 161203)
+++ exp_disp.adb	(working copy)
@@ -1782,7 +1782,7 @@  package body Exp_Disp is
            or else TSS_Name  = TSS_Stream_Output
            or else
              (Chars (E) = Name_Op_Eq
-                and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+                and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
            or else Chars (E) = Name_uAssign
            or else TSS_Name  = TSS_Deep_Adjust
            or else TSS_Name  = TSS_Deep_Finalize
@@ -1824,7 +1824,7 @@  package body Exp_Disp is
            or else Chars (E) = Name_uAlignment
            or else
              (Chars (E) = Name_Op_Eq
-                and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+                and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
            or else Chars (E) = Name_uAssign
            or else TSS_Name  = TSS_Deep_Adjust
            or else TSS_Name  = TSS_Deep_Finalize
Index: exp_cg.adb
===================================================================
--- exp_cg.adb	(revision 161203)
+++ exp_cg.adb	(working copy)
@@ -238,7 +238,7 @@  package body Exp_CG is
               or else Chars (E) = Name_uAlignment
               or else
                 (Chars (E) = Name_Op_Eq
-                   and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+                   and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
               or else Chars (E) = Name_uAssign
               or else Is_Predefined_Interface_Primitive (E)
             then
@@ -283,7 +283,7 @@  package body Exp_CG is
 
                      return Predef_Names_95 (J) /= Name_Op_Eq
                        or else
-                         Etype (First_Entity (E)) = Etype (Last_Entity (E));
+                         Etype (First_Formal (E)) = Etype (Last_Formal (E));
                   end if;
                end loop;