Patchwork [Ada] Implementation of AI05-0123 : composability of equality

login
register
mail settings
Submitter Arnaud Charlet
Date Sept. 9, 2010, 9:31 a.m.
Message ID <20100909093101.GA13949@adacore.com>
Download mbox | patch
Permalink /patch/64264/
State New
Headers show

Comments

Arnaud Charlet - Sept. 9, 2010, 9:31 a.m.
Equality composes for untagged records as well as for tagged ones.

The following must compile and execute quietly
    gnatmake -q -gnat12 ai05_123
    ai05_123

---
procedure AI05_123 is
   package Pkg is
      type Rec is record
         Name : String (1..5) := "wow!!";
      end record;

      function "=" (L, R: Rec) return Boolean is abstract;

      type Drec is new Rec; -- inherits abstract "="

      type Trec is tagged record
         X : Rec;
      end record;

      type T2rec is tagged record
         X : Drec;
      end record;

      type D2rec is new Drec;

      type Vec is array (Boolean) of Drec;

      function "=" (L, R : Drec) return Boolean; --  overrides inherited op.

      type Urec is record
         X : Drec;
      end record;
   end Pkg;

   package body Pkg is
      function "=" (L, R : Drec) return Boolean is
      begin
         --  test first character of component
         return L.Name (1) = R.Name (1);
      end;
   end Pkg;

   use Pkg;

   Vec1 : Vec  := (others => (others => "yes!!"));
   Vec2 : Vec  := (others => (others => "yeah!"));

   It1 :  Urec := (X => Vec1 (True));
   It2 :  Urec := (X => Vec2 (True));

begin

  --  Vector equality uses primitive operation of component type

  if Vec1 /= Vec2 then
    raise Program_Error;
  end if;

   --  record equality uses  primitive operation of component type.
   if It1 /= It2 then
      raise Program_Error;
   end if;

   --  Derived type inherits equality of parent type

   declare
      Dit1 : D2rec := (others => "claro");
      Dit2 : D2rec := (others => "creo?");

   begin
      null;
      if Dit1 /= Dit2 then
         raise Program_Error;
      end if;
   end;

   --  Tagged record equality uses  primitive operation of component type.

   declare
      T1 : T2rec;
      T2 : T2rec := (X => (name => "whew."));
   begin
      null;
      if T1 /= T2 then
         raise Program_error;
      end if;
   end;
end AI05_123;

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

2010-09-09  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb (Build_Untagged_Equality): For Ada2012, new procedure to
	create the primitive equality operation for an untagged record. The
	operation is the predefined equality if no record component has a
	user-defined equality, or if there is a user-defined equality for the
	type as a whole, or when the type is derived and it has an inherited
	equality. Otherwise the body of the operations is built as for tagged
	types.
	(Expand_Freeze_Record_Type): Call Build_Untagged_Equality when needed.
	(Make_Eq_Body): New function to create the expanded body of the equality
	operation for tagged and untagged records.  In both cases the operation
	composes, and the primitive operation of each record component is used
	to generate the equality function for the type.
	* exp_ch4.adb (Expand_Composite_Equality): In Ada2012, if a component
	has an abstract equality defined, replace its call with a
	Raise_Program_Error.
	* sem_ch6.adb (New_Overloaded_Entity): if Ada2012, verify that a
	user-defined equality operator for an untagged record type does not
	happen after type is frozen, and appears in the visible part if partial
	view of type is not limited.

Patch

Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 164000)
+++ exp_ch4.adb	(working copy)
@@ -2170,22 +2170,54 @@  package body Exp_Ch4 is
                            Lhs_Discr_Val,
                            Rhs_Discr_Val));
                   end;
+
+               else
+                  return
+                    Make_Function_Call (Loc,
+                      Name                   => New_Reference_To (Eq_Op, Loc),
+                      Parameter_Associations => New_List (Lhs, Rhs));
                end if;
+            end if;
 
-               --  Shouldn't this be an else, we can't fall through the above
-               --  IF, right???
+         elsif Ada_Version >= Ada_12 then
 
-               return
-                 Make_Function_Call (Loc,
-                   Name => New_Reference_To (Eq_Op, Loc),
-                   Parameter_Associations => New_List (Lhs, Rhs));
-            end if;
+            --  if no TSS has been created for the type, check whether there is
+            --  a primitive equality declared for it. If it is abstract replace
+            --  the call with an explicit raise.
+
+            declare
+               Prim : Elmt_Id;
+
+            begin
+               Prim := First_Elmt (Collect_Primitive_Operations (Full_Type));
+               while Present (Prim) loop
+                  if Chars (Node (Prim)) = Name_Op_Eq then
+                     if Is_Abstract_Subprogram (Node (Prim)) then
+                        return
+                          Make_Raise_Program_Error (Loc,
+                            Reason => PE_Explicit_Raise);
+                     else
+                        return
+                          Make_Function_Call (Loc,
+                            Name => New_Reference_To (Node (Prim), Loc),
+                            Parameter_Associations => New_List (Lhs, Rhs));
+                     end if;
+                  end if;
+
+                  Next_Elmt (Prim);
+               end loop;
+            end;
+
+            --  Predfined equality applies iff no user-defined primitive exists
+
+            return Make_Op_Eq (Loc, Lhs, Rhs);
 
          else
             return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
          end if;
 
       else
+
          --  It can be a simple record or the full view of a scalar private
 
          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 164000)
+++ sem_ch6.adb	(working copy)
@@ -7974,6 +7974,35 @@  package body Sem_Ch6 is
            and then not Is_Dispatching_Operation (S)
          then
             Make_Inequality_Operator (S);
+
+            --  In Ada 2012, a primitive equality operator on a record type
+            --  must appear before the type is frozen, and have the same
+            --  visibility as the type.
+
+            declare
+               Typ  : constant Entity_Id := Etype (First_Formal (S));
+               Decl : constant Node_Id   := Unit_Declaration_Node (S);
+
+            begin
+               if Ada_Version >= Ada_12
+                 and then Nkind (Decl) = N_Subprogram_Declaration
+                 and then Is_Record_Type (Typ)
+               then
+                  if Is_Frozen (Typ) then
+                     Error_Msg_NE
+                       ("equality operator must be declared "
+                         & "before type& is frozen", S, Typ);
+
+                  elsif List_Containing (Parent (Typ))
+                          /=
+                        List_Containing (Decl)
+                    and then not Is_Limited_Type (Typ)
+                  then
+                     Error_Msg_N
+                       ("equality operator appears too late", S);
+                  end if;
+               end if;
+            end;
          end if;
    end New_Overloaded_Entity;
 
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 164000)
+++ exp_ch3.adb	(working copy)
@@ -141,6 +141,12 @@  package body Exp_Ch3 is
    --  the code expansion for controlled components (when control actions
    --  are active) can lead to very large blocks that GCC3 handles poorly.
 
+   procedure Build_Untagged_Equality (Typ : Entity_Id);
+   --  AI05-0123: equality on untagged records composes. This procedure
+   --  build the equality routine for an untagged record that has components
+   --  of a record type that have user-defined primitive equality operations.
+   --  The resulting operation is a TSS subprogram.
+
    procedure Build_Variant_Record_Equality (Typ  : Entity_Id);
    --  Create An Equality function for the non-tagged variant record 'Typ'
    --  and attach it to the TSS list
@@ -220,6 +226,13 @@  package body Exp_Ch3 is
    function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
    --  Returns true if E has variable size components
 
+   function Make_Eq_Body
+     (Typ     : Entity_Id;
+      Eq_Name : Name_Id) return Node_Id;
+   --  Build the body of a primitive equality operation for a tagged record
+   --  type, or in Ada2012 for any record type that has components with a
+   --  user-defined equality. Factored out of Predefined_Primitive_Bodies.
+
    function Make_Eq_Case
      (E     : Entity_Id;
       CL    : Node_Id;
@@ -3745,6 +3758,147 @@  package body Exp_Ch3 is
       Set_Is_Pure (Proc_Name);
    end Build_Slice_Assignment;
 
+   -----------------------------
+   -- Build_Untagged_Equality --
+   -----------------------------
+
+   procedure Build_Untagged_Equality (Typ : Entity_Id) is
+      Build_Eq : Boolean;
+      Comp     : Entity_Id;
+      Decl     : Node_Id;
+      Op       : Entity_Id;
+      Prim     : Elmt_Id;
+      Eq_Op    : Entity_Id;
+
+      function User_Defined_Eq (T : Entity_Id) return Entity_Id;
+      --  Check whether the type T has a user-defined primitive
+      --  equality. If true for a component of Typ, we have to
+      --  build the primitive equality for it.
+
+      ---------------------
+      -- User_Defined_Eq --
+      ---------------------
+
+      function User_Defined_Eq (T : Entity_Id) return Entity_Id is
+         Prim : Elmt_Id;
+         Op   : Entity_Id;
+
+      begin
+         Op := TSS (T, TSS_Composite_Equality);
+
+         if Present (Op) then
+            return Op;
+         end if;
+
+         Prim := First_Elmt (Collect_Primitive_Operations (T));
+         while Present (Prim) loop
+            Op := Node (Prim);
+
+            if Chars (Op) = Name_Op_Eq
+              and then Etype (Op) = Standard_Boolean
+              and then Etype (First_Formal (Op)) = T
+              and then Etype (Next_Formal (First_Formal (Op))) = T
+            then
+               return Op;
+            end if;
+
+            Next_Elmt (Prim);
+         end loop;
+
+         return Empty;
+      end User_Defined_Eq;
+
+   --  Start of processing for Build_Untagged_Equality
+
+   begin
+      --  If a record component has a primitive equality operation, we must
+      --  builde the corresponding one for the current type.
+
+      Build_Eq := False;
+      Comp := First_Component (Typ);
+      while Present (Comp) loop
+         if Is_Record_Type (Etype (Comp))
+           and then Present (User_Defined_Eq (Etype (Comp)))
+         then
+            Build_Eq := True;
+         end if;
+
+         Next_Component (Comp);
+      end loop;
+
+      --  If there is a user-defined equality for the type, we do not create
+      --  the implicit one.
+
+      Prim := First_Elmt (Collect_Primitive_Operations (Typ));
+      Eq_Op := Empty;
+      while Present (Prim) loop
+         if Chars (Node (Prim)) = Name_Op_Eq
+           and then Comes_From_Source (Node (Prim))
+         then
+            Eq_Op := Node (Prim);
+            Build_Eq := False;
+            exit;
+         end if;
+
+         Next_Elmt (Prim);
+      end loop;
+
+      --  If the type is derived, inherit the operation, if present, from the
+      --  parent type. It may have been declared after the type derivation.
+      --  If the parent type itself is derived, it may have inherited an
+      --  operation that has itself been overridden, so update its alias
+      --  and related flags. Ditto for inequality.
+
+      if No (Eq_Op) and then Is_Derived_Type (Typ) then
+         Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
+         while Present (Prim) loop
+            if Chars (Node (Prim)) = Name_Op_Eq then
+               Copy_TSS (Node (Prim), Typ);
+               Build_Eq := False;
+
+               declare
+                  Op    : constant Entity_Id := User_Defined_Eq (Typ);
+                  Eq_Op : constant Entity_Id := Node (Prim);
+                  NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
+
+               begin
+                  if Present (Op) then
+                     Set_Alias (Op, Eq_Op);
+                     Set_Is_Abstract_Subprogram
+                       (Op, Is_Abstract_Subprogram (Eq_Op));
+
+                     if Chars (Next_Entity (Op)) = Name_Op_Ne then
+                        Set_Alias (Next_Entity (Op), NE_Op);
+                        Set_Is_Abstract_Subprogram
+                          (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
+                     end if;
+                  end if;
+               end;
+
+               exit;
+            end if;
+
+            Next_Elmt (Prim);
+         end loop;
+      end if;
+
+      --  If not inherited and not user-defined, build body as for a type
+      --  with tagged components.
+
+      if Build_Eq then
+         Decl :=
+           Make_Eq_Body
+             (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
+         Op := Defining_Entity (Decl);
+         Set_TSS (Typ, Op);
+         Set_Is_Pure (Op);
+
+         if Is_Library_Level_Entity (Typ) then
+            Set_Is_Public (Op);
+         end if;
+      end if;
+   end Build_Untagged_Equality;
+
    ------------------------------------
    -- Build_Variant_Record_Equality --
    ------------------------------------
@@ -6026,8 +6180,10 @@  package body Exp_Ch3 is
             end if;
          end if;
 
-      --  In the non-tagged case, an equality function is provided only for
-      --  variant records (that are not unchecked unions).
+      --  In the non-tagged case, ever since Ada83 an equality function must
+      --  be  provided for variant records that are not unchecked unions.
+      --  In Ada2012 the equality function composes, and thus must be built
+      --  explicitly just as for tagged records.
 
       elsif Has_Discriminants (Def_Id)
         and then not Is_Limited_Type (Def_Id)
@@ -6043,6 +6199,12 @@  package body Exp_Ch3 is
                Build_Variant_Record_Equality (Def_Id);
             end if;
          end;
+
+      elsif Ada_Version >= Ada_12
+        and then Comes_From_Source (Def_Id)
+        and then Convention (Def_Id) = Convention_Ada
+      then
+         Build_Untagged_Equality (Def_Id);
       end if;
 
       --  Before building the record initialization procedure, if we are
@@ -7638,6 +7800,79 @@  package body Exp_Ch3 is
       end loop;
    end Make_Controlling_Function_Wrappers;
 
+   -------------------
+   --  Make_Eq_Body --
+   -------------------
+
+   function Make_Eq_Body
+     (Typ     : Entity_Id;
+      Eq_Name : Name_Id) return Node_Id
+   is
+      Loc          : constant Source_Ptr := Sloc (Parent (Typ));
+      Decl         : Node_Id;
+      Def          : constant Node_Id := Parent (Typ);
+      Stmts        : constant List_Id := New_List;
+      Variant_Case : Boolean := Has_Discriminants (Typ);
+      Comps        : Node_Id := Empty;
+      Typ_Def      : Node_Id := Type_Definition (Def);
+
+   begin
+      Decl :=
+        Predef_Spec_Or_Body (Loc,
+          Tag_Typ => Typ,
+          Name    => Eq_Name,
+          Profile => New_List (
+            Make_Parameter_Specification (Loc,
+              Defining_Identifier =>
+                Make_Defining_Identifier (Loc, Name_X),
+              Parameter_Type      => New_Reference_To (Typ, Loc)),
+
+            Make_Parameter_Specification (Loc,
+              Defining_Identifier =>
+                Make_Defining_Identifier (Loc, Name_Y),
+              Parameter_Type      => New_Reference_To (Typ, Loc))),
+
+          Ret_Type => Standard_Boolean,
+          For_Body => True);
+
+      if Variant_Case then
+         if Nkind (Typ_Def) = N_Derived_Type_Definition then
+            Typ_Def := Record_Extension_Part (Typ_Def);
+         end if;
+
+         if Present (Typ_Def) then
+            Comps := Component_List (Typ_Def);
+         end if;
+
+         Variant_Case := Present (Comps)
+           and then Present (Variant_Part (Comps));
+      end if;
+
+      if Variant_Case then
+         Append_To (Stmts,
+           Make_Eq_If (Typ, Discriminant_Specifications (Def)));
+         Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
+         Append_To (Stmts,
+           Make_Simple_Return_Statement (Loc,
+             Expression => New_Reference_To (Standard_True, Loc)));
+
+      else
+         Append_To (Stmts,
+           Make_Simple_Return_Statement (Loc,
+             Expression =>
+               Expand_Record_Equality
+                 (Typ,
+                  Typ    => Typ,
+                  Lhs    => Make_Identifier (Loc, Name_X),
+                  Rhs    => Make_Identifier (Loc, Name_Y),
+                  Bodies => Declarations (Decl))));
+      end if;
+
+      Set_Handled_Statement_Sequence
+        (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+      return Decl;
+   end Make_Eq_Body;
+
    ------------------
    -- Make_Eq_Case --
    ------------------
@@ -8667,67 +8902,7 @@  package body Exp_Ch3 is
          --  Body for equality
 
          if Eq_Needed then
-            Decl :=
-              Predef_Spec_Or_Body (Loc,
-                Tag_Typ => Tag_Typ,
-                Name    => Eq_Name,
-                Profile => New_List (
-                  Make_Parameter_Specification (Loc,
-                    Defining_Identifier =>
-                      Make_Defining_Identifier (Loc, Name_X),
-                    Parameter_Type      => New_Reference_To (Tag_Typ, Loc)),
-
-                  Make_Parameter_Specification (Loc,
-                    Defining_Identifier =>
-                      Make_Defining_Identifier (Loc, Name_Y),
-                    Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
-
-                Ret_Type => Standard_Boolean,
-                For_Body => True);
-
-            declare
-               Def          : constant Node_Id := Parent (Tag_Typ);
-               Stmts        : constant List_Id := New_List;
-               Variant_Case : Boolean := Has_Discriminants (Tag_Typ);
-               Comps        : Node_Id := Empty;
-               Typ_Def      : Node_Id := Type_Definition (Def);
-
-            begin
-               if Variant_Case then
-                  if Nkind (Typ_Def) = N_Derived_Type_Definition then
-                     Typ_Def := Record_Extension_Part (Typ_Def);
-                  end if;
-
-                  if Present (Typ_Def) then
-                     Comps := Component_List (Typ_Def);
-                  end if;
-
-                  Variant_Case := Present (Comps)
-                    and then Present (Variant_Part (Comps));
-               end if;
-
-               if Variant_Case then
-                  Append_To (Stmts,
-                    Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def)));
-                  Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps));
-                  Append_To (Stmts,
-                    Make_Simple_Return_Statement (Loc,
-                      Expression => New_Reference_To (Standard_True, Loc)));
-
-               else
-                  Append_To (Stmts,
-                    Make_Simple_Return_Statement (Loc,
-                      Expression =>
-                        Expand_Record_Equality (Tag_Typ,
-                          Typ => Tag_Typ,
-                          Lhs => Make_Identifier (Loc, Name_X),
-                          Rhs => Make_Identifier (Loc, Name_Y),
-                          Bodies => Declarations (Decl))));
-               end if;
-
-               Set_Handled_Statement_Sequence (Decl,
-                 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
-            end;
+            Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
             Append_To (Res, Decl);
          end if;