2012-07-12 Robert Dewar <dewar@adacore.com>

	* make.adb, sem_ch9.adb, prj.adb, s-rident.ads, snames.ads-tmpl: Minor
	reformatting.

2012-07-12  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Is_User_Defined_Equality): New subprogram.
	(Make_Neq_Body): New subprogram.
	(Make_Predefined_Primitive_Specs): Adding local variable
	Has_Predef_Eq_ Renaming to ensure that we enable the machinery
	which handles renamings of predefined primitive operators.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@189432 138bc75d-0d04-0410-961f-82ee72b054a4

7 files changed, 273 insertions, 40 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 38b62351cf3..0e30e766c26 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2012-07-12  Robert Dewar  <dewar@adacore.com>
+
+	* make.adb, sem_ch9.adb, prj.adb, s-rident.ads, snames.ads-tmpl: Minor
+	reformatting.
+
+2012-07-12  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch3.adb (Is_User_Defined_Equality): New subprogram.
+	(Make_Neq_Body): New subprogram.
+	(Make_Predefined_Primitive_Specs): Adding local variable
+	Has_Predef_Eq_ Renaming to ensure that we enable the machinery
+	which handles renamings of predefined primitive operators.
+
 2012-07-09  Pascal Obry  <obry@adacore.com>
 
 	* prj.adb (For_Every_Project_Imported_Context): Make sure we
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 7f7aa6f6bb7..369d895906b 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -202,6 +202,9 @@ package body Exp_Ch3 is
    --  Check if E is defined in the RTL (in a child of Ada or System). Used
    --  to avoid to bring in the overhead of _Input, _Output for tagged types.
 
+   function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
+   --  Returns true if Prim is a user defined equality function
+
    function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
    --  Returns true if E has variable size components
 
@@ -237,6 +240,11 @@ package body Exp_Ch3 is
    --  formals at some upper level). E provides the Sloc to be used for the
    --  generated code.
 
+   function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
+   --  Search for a renaming of the inequality dispatching primitive of
+   --  this tagged type. If found then build and return the corresponding
+   --  rename-as-body inequality subprogram; otherwise return Empty.
+
    procedure Make_Predefined_Primitive_Specs
      (Tag_Typ     : Entity_Id;
       Predef_List : out List_Id;
@@ -7677,6 +7685,18 @@ package body Exp_Ch3 is
       end loop;
    end Init_Secondary_Tags;
 
+   ------------------------
+   -- Is_User_Defined_Eq --
+   ------------------------
+
+   function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
+   begin
+      return Chars (Prim) = Name_Op_Eq
+        and then Etype (First_Formal (Prim)) =
+                 Etype (Next_Formal (First_Formal (Prim)))
+        and then Base_Type (Etype (Prim)) = Standard_Boolean;
+   end Is_User_Defined_Equality;
+
    ----------------------------
    -- Is_Variable_Size_Array --
    ----------------------------
@@ -8140,6 +8160,175 @@ package body Exp_Ch3 is
       end if;
    end Make_Eq_If;
 
+   --------------------
+   --  Make_Neq_Body --
+   --------------------
+
+   function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
+
+      function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
+      --  Returns true if Prim is a renaming of an unresolved predefined
+      --  inequality operation.
+
+      --------------------------------
+      -- Is_Predefined_Neq_Renaming --
+      --------------------------------
+
+      function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
+      begin
+         return Chars (Prim) /= Name_Op_Ne
+           and then Present (Alias (Prim))
+           and then Comes_From_Source (Prim)
+           and then Is_Intrinsic_Subprogram (Alias (Prim))
+           and then Chars (Alias (Prim)) = Name_Op_Ne;
+      end Is_Predefined_Neq_Renaming;
+
+      --  Local variables
+
+      Loc           : constant Source_Ptr := Sloc (Parent (Tag_Typ));
+      Stmts         : constant List_Id    := New_List;
+      Decl          : Node_Id;
+      Eq_Prim       : Entity_Id;
+      Left_Op       : Entity_Id;
+      Renaming_Prim : Entity_Id;
+      Right_Op      : Entity_Id;
+      Target        : Entity_Id;
+
+   --  Start of processing for Make_Neq_Body
+
+   begin
+      --  For a call on a renaming of a dispatching subprogram that is
+      --  overridden, if the overriding occurred before the renaming, then
+      --  the body executed is that of the overriding declaration, even if the
+      --  overriding declaration is not visible at the place of the renaming;
+      --  otherwise, the inherited or predefined subprogram is called, see
+      --  (RM 8.5.4(8))
+
+      --  Stage 1: Search for a renaming of the unequality primitive and also
+      --  search for an overriding of the equality primitive located before the
+      --  renaming declaration.
+
+      declare
+         Elmt : Elmt_Id;
+         Prim : Node_Id;
+
+      begin
+         Eq_Prim       := Empty;
+         Renaming_Prim := Empty;
+
+         Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+         while Present (Elmt) loop
+            Prim := Node (Elmt);
+
+            if Is_User_Defined_Equality (Prim)
+              and then No (Alias (Prim))
+            then
+               if No (Renaming_Prim) then
+                  pragma Assert (No (Eq_Prim));
+                  Eq_Prim := Prim;
+               end if;
+
+            elsif Is_Predefined_Neq_Renaming (Prim) then
+               Renaming_Prim := Prim;
+            end if;
+
+            Next_Elmt (Elmt);
+         end loop;
+      end;
+
+      --  No further action needed if no renaming was found
+
+      if No (Renaming_Prim) then
+         return Empty;
+      end if;
+
+      --  Stage 2: Replace the renaming declaration by a subprogram declaration
+      --  (required to add its body)
+
+      Decl := Parent (Parent (Renaming_Prim));
+      Rewrite (Decl,
+        Make_Subprogram_Declaration (Loc,
+          Specification => Specification (Decl)));
+      Set_Analyzed (Decl);
+
+      --  Remove the decoration of intrinsic renaming subprogram
+
+      Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
+      Set_Convention (Renaming_Prim, Convention_Ada);
+      Set_Alias (Renaming_Prim, Empty);
+      Set_Has_Completion (Renaming_Prim, False);
+
+      --  Stage 3: Build the corresponding body
+
+      Left_Op  := First_Formal (Renaming_Prim);
+      Right_Op := Next_Formal (Left_Op);
+
+      Decl :=
+        Predef_Spec_Or_Body (Loc,
+          Tag_Typ => Tag_Typ,
+          Name    => Chars (Renaming_Prim),
+          Profile => New_List (
+            Make_Parameter_Specification (Loc,
+              Defining_Identifier =>
+                Make_Defining_Identifier (Loc, Chars (Left_Op)),
+              Parameter_Type      => New_Reference_To (Tag_Typ, Loc)),
+
+            Make_Parameter_Specification (Loc,
+              Defining_Identifier =>
+                Make_Defining_Identifier (Loc, Chars (Right_Op)),
+              Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
+
+          Ret_Type => Standard_Boolean,
+          For_Body => True);
+
+      --  If the overriding of the equality primitive occurred before the
+      --  renaming, then generate:
+
+      --    function <Neq_Name> (X : Y : Typ) return Boolean is
+      --    begin
+      --       return not Oeq (X, Y);
+      --    end;
+
+      if Present (Eq_Prim) then
+         Target := Eq_Prim;
+
+      --  Otherwise build a nested subprogram which performs the predefined
+      --  evaluation of the equality operator. That is, generate:
+
+      --    function <Neq_Name> (X : Y : Typ) return Boolean is
+      --       function Oeq (X : Y) return Boolean is
+      --       begin
+      --          <<body of default implementation>>
+      --       end;
+      --    begin
+      --       return not Oeq (X, Y);
+      --    end;
+
+      else
+         declare
+            Local_Subp : Node_Id;
+         begin
+            Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
+            Set_Declarations (Decl, New_List (Local_Subp));
+            Target := Defining_Entity (Local_Subp);
+         end;
+      end if;
+
+      Append_To (Stmts,
+        Make_Simple_Return_Statement (Loc,
+          Expression =>
+            Make_Op_Not (Loc,
+              Make_Function_Call (Loc,
+                Name => New_Reference_To (Target, Loc),
+                Parameter_Associations => New_List (
+                  Make_Identifier (Loc, Chars (Left_Op)),
+                  Make_Identifier (Loc, Chars (Right_Op)))))));
+
+      Set_Handled_Statement_Sequence
+        (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+      return Decl;
+   end Make_Neq_Body;
+
    -------------------------------
    -- Make_Null_Procedure_Specs --
    -------------------------------
@@ -8238,13 +8427,6 @@ package body Exp_Ch3 is
       Predef_List : out List_Id;
       Renamed_Eq  : out Entity_Id)
    is
-      Loc       : constant Source_Ptr := Sloc (Tag_Typ);
-      Res       : constant List_Id    := New_List;
-      Eq_Name   : Name_Id := Name_Op_Eq;
-      Eq_Needed : Boolean;
-      Eq_Spec   : Node_Id;
-      Prim      : Elmt_Id;
-
       function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
       --  Returns true if Prim is a renaming of an unresolved predefined
       --  equality operation.
@@ -8262,6 +8444,19 @@ package body Exp_Ch3 is
            and then Chars (Alias (Prim)) = Name_Op_Eq;
       end Is_Predefined_Eq_Renaming;
 
+      --  Local variables
+
+      Loc       : constant Source_Ptr := Sloc (Tag_Typ);
+      Res       : constant List_Id    := New_List;
+      Eq_Name   : Name_Id := Name_Op_Eq;
+      Eq_Needed : Boolean;
+      Eq_Spec   : Node_Id;
+      Prim      : Elmt_Id;
+
+      Has_Predef_Eq_Renaming : Boolean := False;
+      --  Set to True if Tag_Typ has a primitive that renames the predefined
+      --  equality operator. Used to implement (RM 8-5-4(8)).
+
    --  Start of processing for Make_Predefined_Primitive_Specs
 
    begin
@@ -8299,9 +8494,9 @@ package body Exp_Ch3 is
          end loop;
       end;
 
-      --  Spec of "=" is expanded if the type is not limited and if a
-      --  user defined "=" was not already declared for the non-full
-      --  view of a private extension
+      --  Spec of "=" is expanded if the type is not limited and if a user
+      --  defined "=" was not already declared for the non-full view of a
+      --  private extension
 
       if not Is_Limited_Type (Tag_Typ) then
          Eq_Needed := True;
@@ -8311,21 +8506,18 @@ package body Exp_Ch3 is
             --  If a primitive is encountered that renames the predefined
             --  equality operator before reaching any explicit equality
             --  primitive, then we still need to create a predefined equality
-            --  function, because calls to it can occur via the renaming. A new
-            --  name is created for the equality to avoid conflicting with any
-            --  user-defined equality. (Note that this doesn't account for
+            --  function, because calls to it can occur via the renaming. A
+            --  new name is created for the equality to avoid conflicting with
+            --  any user-defined equality. (Note that this doesn't account for
             --  renamings of equality nested within subpackages???)
 
             if Is_Predefined_Eq_Renaming (Node (Prim)) then
+               Has_Predef_Eq_Renaming := True;
                Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
 
             --  User-defined equality
 
-            elsif Chars (Node (Prim)) = Name_Op_Eq
-              and then Etype (First_Formal (Node (Prim))) =
-                         Etype (Next_Formal (First_Formal (Node (Prim))))
-              and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
-            then
+            elsif Is_User_Defined_Equality (Node (Prim)) then
                if No (Alias (Node (Prim)))
                  or else Nkind (Unit_Declaration_Node (Node (Prim))) =
                            N_Subprogram_Renaming_Declaration
@@ -8394,7 +8586,7 @@ package body Exp_Ch3 is
                 Ret_Type => Standard_Boolean);
             Append_To (Res, Eq_Spec);
 
-            if Eq_Name /= Name_Op_Eq then
+            if Has_Predef_Eq_Renaming then
                Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
 
                Prim := First_Elmt (Primitive_Operations (Tag_Typ));
@@ -8966,6 +9158,14 @@ package body Exp_Ch3 is
             Append_To (Res, Decl);
          end if;
 
+         --  Body for inequality (if required!)
+
+         Decl := Make_Neq_Body (Tag_Typ);
+
+         if Present (Decl) then
+            Append_To (Res, Decl);
+         end if;
+
          --  Body for dispatching assignment
 
          Decl :=
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 91d64b51437..dca504d7919 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -4807,8 +4807,10 @@ package body Make is
          return;
       end if;
 
-      --  Regenerate libraries, if there are any and if object files
-      --  have been regenerated.
+      --  Regenerate libraries, if there are any and if object files have been
+      --  regenerated. Note that we skip this in CodePeer mode because we don't
+      --  need libraries in this case, and more importantly, the object files
+      --  may not be present.
 
       if Main_Project /= No_Project
         and then not CodePeer_Mode
diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb
index d70315bbbbc..150d524d30f 100644
--- a/gcc/ada/prj.adb
+++ b/gcc/ada/prj.adb
@@ -599,12 +599,14 @@ package body Prj is
 
             function Has_Sources (P : Project_Id) return Boolean is
                Lang : Language_Ptr;
+
             begin
                Lang := P.Languages;
                while Lang /= No_Language_Index loop
                   if Lang.First_Source /= No_Source then
                      return True;
                   end if;
+
                   Lang := Lang.Next;
                end loop;
 
@@ -617,6 +619,7 @@ package body Prj is
 
             function Get_From_Tree (P : Project_Id) return Project_Id is
                List : Project_List := Tree.Projects;
+
             begin
                if not Has_Sources (P) then
                   while List /= null loop
@@ -625,6 +628,7 @@ package body Prj is
                      then
                         return List.Project;
                      end if;
+
                      List := List.Next;
                   end loop;
                end if;
@@ -632,8 +636,12 @@ package body Prj is
                return P;
             end Get_From_Tree;
 
+            --  Local variables
+
             List : Project_List;
 
+         --  Start of processing for Recursive_Check
+
          begin
             if not Seen_Name.Contains (Project.Name) then
 
diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads
index d067f3d7f4f..11943f074c3 100644
--- a/gcc/ada/s-rident.ads
+++ b/gcc/ada/s-rident.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -30,16 +30,17 @@
 ------------------------------------------------------------------------------
 
 --  This package defines the set of restriction identifiers. It is a generic
---  package that is instantiated by the compiler/binder in package Rident, and
---  is instantiated in package System.Restrictions for use at run-time.
+--  package that is instantiated by the binder for output of the restrictions
+--  structure, and is instantiated in package System.Restrictions for use at
+--  run-time.
 
 --  The reason that we make this a generic package is so that in the case of
---  the instantiation in Rident for use at compile time and bind time, we can
---  generate normal image tables for the enumeration types, which are needed
---  for diagnostic and informational messages. At run-time we really do not
---  want to waste the space for these image tables, and they are not needed,
---  so we can do the instantiation under control of Discard_Names to remove
---  the tables.
+--  the instantiation in the binder, we can generate normal image tables for
+--  the enumeration types, which are needed for diagnostic and informational
+--  messages as well as for identification of restrictions. At run-time we
+--  really do not want to waste the space for these image tables, and they are
+--  not needed, so we can do the instantiation under control of Discard_Names
+--  to remove the tables.
 
 pragma Compiler_Unit;
 
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 6a9fedf253a..d6141bc1e05 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -244,6 +244,9 @@ package body Sem_Ch9 is
                ----------------
 
                function Check_Node (N : Node_Id) return Traverse_Result is
+
+                  --  The following function belongs in sem_eval ???
+
                   function Is_Static_Function (Attr : Node_Id) return Boolean;
                   --  Given an attribute reference node Attr, return True if
                   --  Attr denotes a static function according to the rules in
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index f4facab956b..27ee72e2c89 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -953,18 +953,24 @@ package Snames is
    Last_Attribute_Name                 : constant Name_Id := N + $;
 
    --  Names of internal attributes. They are not real attributes but special
-   --  names used internally by GNAT in order to deal with certain delayed
-   --  aspects (Aspect_CPU, Aspect_Dispatching_Domain,
-   --  Aspect_Interrupt_Priority) that don't have corresponding pragmas or
-   --  user-referencable attributes. It is convenient to have these internal
-   --  attributes available in processing the aspects, since the normal
-   --  approach is to convert an aspect into its corresponding pragma or
-   --  attribute specification.
+   --  names used internally by GNAT in order to deal with delayed aspects
+   --  (Aspect_CPU, Aspect_Dispatching_Domain, Aspect_Interrupt_Priority) that
+   --  don't have corresponding pragmas or user-referencable attributes.
+
+   --  It is convenient to have these internal attributes available for
+   --  processing the aspects, since the normal approach is to convert an
+   --  aspect into its corresponding pragma or attribute specification.
+
+   --  These attributes do have Attribute_Id values so that case statements
+   --  on Attribute_Id include these cases, but they are NOT included in the
+   --  Attribute_Name subtype defined above, which is typically used in the
+   --  front end for checking syntax of submitted programs (where the use of
+   --  internal attributes is not permitted).
 
    First_Internal_Attribute_Name       : constant Name_Id := N + $;
-   Name_CPU                            : constant Name_Id := N + $; -- INT
-   Name_Dispatching_Domain             : constant Name_Id := N + $; -- INT
-   Name_Interrupt_Priority             : constant Name_Id := N + $; -- INT
+   Name_CPU                            : constant Name_Id := N + $;
+   Name_Dispatching_Domain             : constant Name_Id := N + $;
+   Name_Interrupt_Priority             : constant Name_Id := N + $;
    Last_Internal_Attribute_Name        : constant Name_Id := N + $;
 
    --  Names of recognized locking policy identifiers