Patchwork [Ada] Semantics of equality renaming in Ada2012

login
register
mail settings
Submitter Arnaud Charlet
Date Sept. 9, 2010, 10:05 a.m.
Message ID <20100909100540.GA22041@adacore.com>
Download mbox | patch
Permalink /patch/64275/
State New
Headers show

Comments

Arnaud Charlet - Sept. 9, 2010, 10:05 a.m.
A renaming of equality on an untagged record type captures the meaning of
equality at the point of the renaming. A later user-defined equality on
the type of some component may affect primitive equality for the type, so
a body for the renaming must be built at the point of the renaming declaration
rather than waiting for an appropriate freeze point for the type. This is
technically known as squirelling semantics.

The following must compile and execute quietly:

    gnatmake -gnat12 -q ai05_123_3

package Ren is
   type Rec is record
      Name : String (1..5) := "heh??";
   end record;

   type Wrap is record
     Contents : Rec;
   end record;

   function Egal (First, Second : Wrap) return Boolean;
   function Equals (First, Second : Wrap) return Boolean renames "=";

   function "=" (X, Y : Rec) return Boolean;
   function Igual (Un, Deux : Wrap) return Boolean renames "=";
end Ren;
---
package body Ren is

  function Egal (first : wrap; second : wrap) return boolean is
  begin
     return first.contents.name = second.contents.name;
  end Egal;

   function "=" (X, Y : Rec) return Boolean is
   begin
      return X.Name (1) = Y.Name (1);
   end "=";
end Ren;
---
with Ren; use Ren;
procedure AI05_123_3 is
  Obj1 : Rec := (Name => "wow!!");
  Obj2 : Rec := (Name => "whew!");

  W1   : Wrap := (Contents => Obj1);
  W2   : Wrap := (Contents => Obj2);
begin

--  early renaming uses predefined equality
  if Equals (W1, W2) then
      raise Program_Error;
  end if;

  if Egal (W1, W2) then
      raise Program_Error;
  end if;

  --  user defined equality
  if W1 /= W2  then
     raise Program_Error;
  end if;

-- renamed user-defined equality.
 if not Igual (W1, W2)  then
    raise Program_Error;
 end if;
end;

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

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

	* exp_ch3.adb (Build_Untagged_Equality): Do not set alias of implicit
	inequality, it is always rewritten as the negation of the corresponding
	equality operation.
	* exp_ch8.adb (Expand_N_Subprogram_Renaming): If the subprogram renames
	the predefined equality of an untagged record, create a body at the
	point of the renaming, to capture the current meaning of equality for
	the type.

Patch

Index: exp_ch8.adb
===================================================================
--- exp_ch8.adb	(revision 164000)
+++ exp_ch8.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -25,16 +25,22 @@ 
 
 with Atree;    use Atree;
 with Einfo;    use Einfo;
+with Exp_Ch4;  use Exp_Ch4;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Dbug; use Exp_Dbug;
 with Exp_Util; use Exp_Util;
 with Freeze;   use Freeze;
+with Namet;    use Namet;
+with Nmake;    use Nmake;
 with Nlists;   use Nlists;
 with Opt;      use Opt;
 with Sem;      use Sem;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
+with Snames;   use Snames;
 with Stand;    use Stand;
+with Tbuild;   use Tbuild;
 
 package body Exp_Ch8 is
 
@@ -350,6 +356,74 @@  package body Exp_Ch8 is
       elsif Nkind (Nam) = N_Explicit_Dereference then
          Force_Evaluation (Prefix (Nam));
       end if;
+
+      --  Check whether this is a renaming of a predefined equality on an
+      --  untagged record type  (AI05-0123).
+
+      if Is_Entity_Name (Nam)
+        and then Chars (Entity (Nam)) = Name_Op_Eq
+        and then Scope (Entity (Nam)) = Standard_Standard
+        and then Ada_Version >= Ada_2012
+      then
+         declare
+            Loc : constant Source_Ptr := Sloc (N);
+            Id  : constant Entity_Id  := Defining_Entity (N);
+            Typ : constant Entity_Id  := Etype (First_Formal (Id));
+
+            Decl : Node_Id;
+            Body_Id : constant Entity_Id
+              := Make_Defining_Identifier (Sloc (N), Chars (Id));
+
+         begin
+            if Is_Record_Type (Typ)
+              and then not Is_Tagged_Type (Typ)
+              and then not Is_Frozen (Typ)
+            then
+               --  Build body for renamed equality, to capture its current
+               --  meaning. It may be redefined later, but the renaming is
+               --  elaborated where it occurs. This is technically known as
+               --  Squirreling semantics. Renaming is rewritten as a subprogram
+               --  declaration, and the body is inserted at the end of the
+               --  current declaration list to prevent premature freezing.
+
+               Set_Alias (Id, Empty);
+               Set_Has_Completion (Id, False);
+               Rewrite (N,
+                 Make_Subprogram_Declaration (Sloc (N),
+                   Specification => Specification (N)));
+               Set_Has_Delayed_Freeze (Id);
+
+               Decl := Make_Subprogram_Body (Loc,
+                 Specification =>
+                   Make_Function_Specification (Loc,
+                     Defining_Unit_Name => Body_Id,
+                     Parameter_Specifications => Copy_Parameter_List (Id),
+                     Result_Definition =>
+                       New_Occurrence_Of (Standard_Boolean, Loc)),
+                 Declarations => Empty_List,
+                 Handled_Statement_Sequence => Empty);
+
+               Set_Handled_Statement_Sequence (Decl,
+                 Make_Handled_Sequence_Of_Statements (Loc,
+                   Statements => New_List (
+                     Make_Simple_Return_Statement (Loc,
+                       Expression =>
+                          Expand_Record_Equality (
+                            Id,
+                            Typ => Typ,
+                            Lhs =>
+                              Make_Identifier (Loc,
+                                Chars (First_Formal (Id))),
+                            Rhs =>
+                              Make_Identifier (Loc,
+                                Chars (Next_Formal (First_Formal (Id)))),
+                            Bodies => Declarations (Decl))))));
+
+               Append (Decl, List_Containing (N));
+               Set_Debug_Info_Needed (Body_Id);
+            end if;
+         end;
+      end if;
    end Expand_N_Subprogram_Renaming_Declaration;
 
 end Exp_Ch8;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 164062)
+++ exp_ch3.adb	(working copy)
@@ -3873,7 +3873,6 @@  package body Exp_Ch3 is
                        (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;