2013-04-11 Robert Dewar <dewar@adacore.com>

	* atree.h: Add declarations for Flag255-Flag289 Fix declaration
	of Field30 (was wrong, but no effect, since not yet referenced by
	back end) Add declarations for Field31-Field35 Add declarations
	for Node31-Node35.
	* einfo.ads, einfo.adb (Has_Invariants): No longer applies to
	procedures.
	(Has_Predicates): No longer applies to functions.
	(Is_Predicate_Function): New flag.
	(Is_Predicate_Function_M): New flag.
	(Is_Invariant_Procedure): New flag.
	(Predicate_Function_M): New function.
	(Set_Predicate_Function_M): New procedure.
	* exp_ch11.adb (Expand_N_Raise_Expression): Take care of special
	case of appearing in predicate used for membership test.
	* exp_ch3.adb (Insert_Component_Invariant_Checks): Set
	Is_Invariant_Procedure flag.
	* exp_ch4.adb (Expand_Op_In): Call special predicate function
	that takes care of raise_expression nodes in the predicate.
	* exp_util.ads, exp_util.adb (Make_Predicate_Call): Add argument Mem for
	membership case.
	* sem_ch13.adb (Build_Predicate_Functions): New name for
	Build_Predicate_Function.  Major rewrite to take care of raise
	expression in predicate for membership tests.
	* sem_res.adb (Resolve_Actuals): Include both predicate functions
	in defense against infinite predicate function loops.
	* sinfo.ads, sinfo.adb (Convert_To_Return_False): New flag.

2013-04-11  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb: Minor reformatting.

2013-04-11  Ed Schonberg  <schonberg@adacore.com>

	* lib-xref.adb: Generate reference for component of anonymous
	access type.



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

1 files changed, 271 insertions, 81 deletions

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 5d87d3d1e32..4f2d56c1684 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -82,7 +82,7 @@ package body Sem_Ch13 is
    --  type whose inherited alignment is no longer appropriate for the new
    --  size value. In this case, we reset the Alignment to unknown.
 
-   procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);
+   procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
    --  If Typ has predicates (indicated by Has_Predicates being set for Typ,
    --  then either there are pragma Predicate entries on the rep chain for the
    --  type (note that Predicate aspects are converted to pragma Predicate), or
@@ -90,7 +90,9 @@ package body Sem_Ch13 is
    --  This procedure builds the spec and body for the Predicate function that
    --  tests these predicates. N is the freeze node for the type. The spec of
    --  the function is inserted before the freeze node, and the body of the
-   --  function is inserted after the freeze node.
+   --  function is inserted after the freeze node. If the predicate expression
+   --  has at least one Raise_Expression, then this procedure also builds the
+   --  M version of the predicate function for ue in membership tests.
 
    procedure Build_Static_Predicate
      (Typ  : Entity_Id;
@@ -4689,12 +4691,12 @@ package body Sem_Ch13 is
       --  If we have a type with predicates, build predicate function
 
       if Is_Type (E) and then Has_Predicates (E) then
-         Build_Predicate_Function (E, N);
+         Build_Predicate_Functions (E, N);
       end if;
 
       --  If type has delayed aspects, this is where we do the preanalysis at
       --  the freeze point, as part of the consistent visibility check. Note
-      --  that this must be done after calling Build_Predicate_Function or
+      --  that this must be done after calling Build_Predicate_Functions or
       --  Build_Invariant_Procedure since these subprograms fix occurrences of
       --  the subtype name in the saved expression so that they will not cause
       --  trouble in the preanalysis.
@@ -5225,9 +5227,9 @@ package body Sem_Ch13 is
       SId :=
         Make_Defining_Identifier (Loc,
           Chars => New_External_Name (Chars (Typ), "Invariant"));
-      Set_Has_Invariants (SId);
       Set_Has_Invariants (Typ);
       Set_Ekind (SId, E_Procedure);
+      Set_Is_Invariant_Procedure (SId);
       Set_Invariant_Procedure (Typ, SId);
 
       Spec :=
@@ -5597,11 +5599,11 @@ package body Sem_Ch13 is
       end if;
    end Build_Invariant_Procedure;
 
-   ------------------------------
-   -- Build_Predicate_Function --
-   ------------------------------
+   -------------------------------
+   -- Build_Predicate_Functions --
+   -------------------------------
 
-   --  The procedure that is constructed here has the form:
+   --  The procedures that are constructed here has the form:
 
    --    function typPredicate (Ixxx : typ) return Boolean is
    --    begin
@@ -5618,17 +5620,38 @@ package body Sem_Ch13 is
    --  inherited. Note that we do NOT generate Check pragmas, that's because we
    --  use this function even if checks are off, e.g. for membership tests.
 
-   procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is
-      Loc   : constant Source_Ptr := Sloc (Typ);
-      Spec  : Node_Id;
-      SId   : Entity_Id;
-      FDecl : Node_Id;
-      FBody : Node_Id;
+   --  If the expression has at least one Raise_Expression, then we also build
+   --  the typPredicateM version of the function, in which any occurence of a
+   --  Raise_Expressioon is converted to "return False".
+
+   procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is
+      Loc : constant Source_Ptr := Sloc (Typ);
 
       Expr : Node_Id;
-      --  This is the expression for the return statement in the function. It
+      --  This is the expression for the result of the function. It is
       --  is build by connecting the component predicates with AND THEN.
 
+      Expr_M : Node_Id;
+      --  This is the corresponding return expression for the Predicate_M
+      --  function. It differs in that raise expressions are marked for
+      --  special expansion (see Process_REs).
+
+      Object_Name : constant Name_Id := New_Internal_Name ('I');
+      --  Name for argument of Predicate procedure. Note that we use the same
+      --  name for both predicate procedure. That way the reference within the
+      --  predicate expression is the same in both functions.
+
+      Object_Entity : constant Entity_Id :=
+                        Make_Defining_Identifier (Loc, Chars => Object_Name);
+      --  Entity for argument of Predicate procedure
+
+      Object_Entity_M : constant Entity_Id :=
+                         Make_Defining_Identifier (Loc, Chars => Object_Name);
+      --  Entity for argument of Predicate_M procedure
+
+      Raise_Expression_Present : Boolean := False;
+      --  Set True if Expr has at least one Raise_Expression
+
       procedure Add_Call (T : Entity_Id);
       --  Includes a call to the predicate function for type T in Expr if T
       --  has predicates and Predicate_Function (T) is non-empty.
@@ -5639,12 +5662,19 @@ package body Sem_Ch13 is
       --  Inheritance of predicates for the parent type is done by calling the
       --  Predicate_Function of the parent type, using Add_Call above.
 
-      Object_Name : constant Name_Id := New_Internal_Name ('I');
-      --  Name for argument of Predicate procedure
+      function Test_RE (N : Node_Id) return Traverse_Result;
+      --  Used in Test_REs, tests one node for being a raise expression, and if
+      --  so sets Raise_Expression_Present True.
 
-      Object_Entity : constant Entity_Id :=
-                        Make_Defining_Identifier (Loc, Object_Name);
-      --  The entity for the spec entity for the argument
+      procedure Test_REs is new Traverse_Proc (Test_RE);
+      --  Tests to see if Expr contains any raise expressions
+
+      function Process_RE (N : Node_Id) return Traverse_Result;
+      --  Used in Process REs, tests if node N is a raise expression, and if
+      --  so, marks it to be converted to return False.
+
+      procedure Process_REs is new Traverse_Proc (Process_RE);
+      --  Marks any raise expressions in Expr_M to return False
 
       Dynamic_Predicate_Present : Boolean := False;
       --  Set True if a dynamic predicate is present, results in the entire
@@ -5730,8 +5760,8 @@ package body Sem_Ch13 is
             Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
             --  Use the Sloc of the usage name, not the defining name
 
-            Set_Entity (N, Object_Entity);
             Set_Etype (N, Typ);
+            Set_Entity (N, Object_Entity);
 
             --  We want to treat the node as if it comes from source, so that
             --  ASIS will not ignore it
@@ -5830,13 +5860,37 @@ package body Sem_Ch13 is
          end loop;
       end Add_Predicates;
 
-   --  Start of processing for Build_Predicate_Function
+      ----------------
+      -- Process_RE --
+      ----------------
 
-   begin
-      --  Initialize for construction of statement list
+      function Process_RE (N : Node_Id) return Traverse_Result is
+      begin
+         if Nkind (N) = N_Raise_Expression then
+            Set_Convert_To_Return_False (N);
+            return Skip;
+         else
+            return OK;
+         end if;
+      end Process_RE;
 
-      Expr := Empty;
+      -------------
+      -- Test_RE --
+      -------------
 
+      function Test_RE (N : Node_Id) return Traverse_Result is
+      begin
+         if Nkind (N) = N_Raise_Expression then
+            Raise_Expression_Present := True;
+            return Abandon;
+         else
+            return OK;
+         end if;
+      end Test_RE;
+
+   --  Start of processing for Build_Predicate_Functions
+
+   begin
       --  Return if already built or if type does not have predicates
 
       if not Has_Predicates (Typ)
@@ -5845,6 +5899,10 @@ package body Sem_Ch13 is
          return;
       end if;
 
+      --  Prepare to construct predicate expression
+
+      Expr := Empty;
+
       --  Add Predicates for the current type
 
       Add_Predicates;
@@ -5859,69 +5917,198 @@ package body Sem_Ch13 is
          end if;
       end;
 
-      --  If we have predicates, build the function
+      --  Case where predicates are present
 
       if Present (Expr) then
 
-         --  Build function declaration
+         --  Test for raise expression present
 
-         SId :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_External_Name (Chars (Typ), "Predicate"));
-         Set_Has_Predicates (SId);
-         Set_Ekind (SId, E_Function);
-         Set_Predicate_Function (Typ, SId);
+         Test_REs (Expr);
 
-         --  The predicate function is shared between views of a type.
+         --  If raise expression is present, capture a copy of Expr for use
+         --  in building the predicateM function version later on. For this
+         --  copy we replace references to Object_Entity by Object_Entity_M.
 
-         if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
-            Set_Predicate_Function (Full_View (Typ), SId);
+         if Raise_Expression_Present then
+            declare
+               Map : constant Elist_Id := New_Elmt_List;
+            begin
+               Append_Elmt (Object_Entity, Map);
+               Append_Elmt (Object_Entity_M, Map);
+               Expr_M := New_Copy_Tree (Expr, Map => Map);
+            end;
          end if;
 
-         Spec :=
-           Make_Function_Specification (Loc,
-             Defining_Unit_Name       => SId,
-             Parameter_Specifications => New_List (
-               Make_Parameter_Specification (Loc,
-                 Defining_Identifier => Object_Entity,
-                 Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
-             Result_Definition        =>
-               New_Occurrence_Of (Standard_Boolean, Loc));
-
-         FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
-
-         --  Build function body
-
-         SId :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_External_Name (Chars (Typ), "Predicate"));
-
-         Spec :=
-           Make_Function_Specification (Loc,
-             Defining_Unit_Name       => SId,
-             Parameter_Specifications => New_List (
-               Make_Parameter_Specification (Loc,
-                 Defining_Identifier =>
-                   Make_Defining_Identifier (Loc, Object_Name),
-                 Parameter_Type =>
-                   New_Occurrence_Of (Typ, Loc))),
-             Result_Definition        =>
-               New_Occurrence_Of (Standard_Boolean, Loc));
-
-         FBody :=
-           Make_Subprogram_Body (Loc,
-             Specification              => Spec,
-             Declarations               => Empty_List,
-             Handled_Statement_Sequence =>
-               Make_Handled_Sequence_Of_Statements (Loc,
-                 Statements => New_List (
-                   Make_Simple_Return_Statement (Loc,
-                     Expression => Expr))));
+         --  Build the main predicate function
+
+         declare
+            SId : constant Entity_Id :=
+                    Make_Defining_Identifier (Loc,
+                      Chars => New_External_Name (Chars (Typ), "Predicate"));
+            --  The entity for the the function spec
+
+            SIdB : constant Entity_Id :=
+              Make_Defining_Identifier (Loc,
+                Chars => New_External_Name (Chars (Typ), "Predicate"));
+            --  The entity for the function body
+
+            Spec  : Node_Id;
+            FDecl : Node_Id;
+            FBody : Node_Id;
+
+         begin
+            --  Build function declaration
+
+            Set_Ekind (SId, E_Function);
+            Set_Is_Predicate_Function (SId);
+            Set_Predicate_Function (Typ, SId);
+
+            --  The predicate function is shared between views of a type
+
+            if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+               Set_Predicate_Function (Full_View (Typ), SId);
+            end if;
+
+            Spec :=
+              Make_Function_Specification (Loc,
+                Defining_Unit_Name       => SId,
+                Parameter_Specifications => New_List (
+                  Make_Parameter_Specification (Loc,
+                    Defining_Identifier => Object_Entity,
+                    Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
+                Result_Definition        =>
+                  New_Occurrence_Of (Standard_Boolean, Loc));
+
+            FDecl :=
+              Make_Subprogram_Declaration (Loc,
+                Specification => Spec);
 
-         --  Insert declaration before freeze node and body after
+            --  Build function body
 
-         Insert_Before_And_Analyze (N, FDecl);
-         Insert_After_And_Analyze  (N, FBody);
+            Spec :=
+              Make_Function_Specification (Loc,
+                Defining_Unit_Name       => SIdB,
+                Parameter_Specifications => New_List (
+                  Make_Parameter_Specification (Loc,
+                    Defining_Identifier =>
+                      Make_Defining_Identifier (Loc, Object_Name),
+                    Parameter_Type =>
+                      New_Occurrence_Of (Typ, Loc))),
+                Result_Definition        =>
+                  New_Occurrence_Of (Standard_Boolean, Loc));
+
+            FBody :=
+              Make_Subprogram_Body (Loc,
+                Specification              => Spec,
+                Declarations               => Empty_List,
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc,
+                    Statements => New_List (
+                      Make_Simple_Return_Statement (Loc,
+                        Expression => Expr))));
+
+            --  Insert declaration before freeze node and body after
+
+            Insert_Before_And_Analyze (N, FDecl);
+            Insert_After_And_Analyze  (N, FBody);
+         end;
+
+         --  Test for raise expressions present and if so build M version
+
+         if Raise_Expression_Present then
+            declare
+               SId : constant Entity_Id :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Chars (Typ), "PredicateM"));
+               --  The entity for the the function spec
+
+               SIdB : constant Entity_Id :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Chars (Typ), "PredicateM"));
+               --  The entity for the function body
+
+               Spec  : Node_Id;
+               FDecl : Node_Id;
+               FBody : Node_Id;
+               BTemp : Entity_Id;
+
+            begin
+               --  Mark any raise expressions for special expansion
+
+               Process_REs (Expr_M);
+
+               --  Build function declaration
+
+               Set_Ekind (SId, E_Function);
+               Set_Is_Predicate_Function_M (SId);
+               Set_Predicate_Function_M (Typ, SId);
+
+               --  The predicate function is shared between views of a type
+
+               if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+                  Set_Predicate_Function_M (Full_View (Typ), SId);
+               end if;
+
+               Spec :=
+                 Make_Function_Specification (Loc,
+                   Defining_Unit_Name       => SId,
+                   Parameter_Specifications => New_List (
+                     Make_Parameter_Specification (Loc,
+                       Defining_Identifier => Object_Entity_M,
+                       Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
+                   Result_Definition        =>
+                     New_Occurrence_Of (Standard_Boolean, Loc));
+
+               FDecl :=
+                 Make_Subprogram_Declaration (Loc,
+                   Specification => Spec);
+
+               --  Build function body
+
+               Spec :=
+                 Make_Function_Specification (Loc,
+                   Defining_Unit_Name       => SIdB,
+                   Parameter_Specifications => New_List (
+                     Make_Parameter_Specification (Loc,
+                       Defining_Identifier =>
+                         Make_Defining_Identifier (Loc, Object_Name),
+                       Parameter_Type =>
+                         New_Occurrence_Of (Typ, Loc))),
+                   Result_Definition        =>
+                     New_Occurrence_Of (Standard_Boolean, Loc));
+
+               --  Build the body, we declare the boolean expression before
+               --  doing the return, because we are not really confident of
+               --  what happens if a return appears within a return!
+
+               BTemp :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_Internal_Name ('B'));
+
+               FBody :=
+                 Make_Subprogram_Body (Loc,
+                   Specification              => Spec,
+
+                   Declarations               => New_List (
+                     Make_Object_Declaration (Loc,
+                       Defining_Identifier => BTemp,
+                       Constant_Present    => True,
+                         Object_Definition =>
+                           New_Reference_To (Standard_Boolean, Loc),
+                         Expression        => Expr_M)),
+
+                   Handled_Statement_Sequence =>
+                     Make_Handled_Sequence_Of_Statements (Loc,
+                       Statements => New_List (
+                         Make_Simple_Return_Statement (Loc,
+                           Expression => New_Reference_To (BTemp, Loc)))));
+
+               --  Insert declaration before freeze node and body after
+
+               Insert_Before_And_Analyze (N, FDecl);
+               Insert_After_And_Analyze  (N, FBody);
+            end;
+         end if;
 
          --  Deal with static predicate case
 
@@ -5944,7 +6131,7 @@ package body Sem_Ch13 is
             end if;
          end if;
       end if;
-   end Build_Predicate_Function;
+   end Build_Predicate_Functions;
 
    ----------------------------
    -- Build_Static_Predicate --
@@ -6449,7 +6636,10 @@ package body Sem_Ch13 is
                   declare
                      Ent : constant Entity_Id := Entity (Name (Exp));
                   begin
-                     if Has_Predicates (Ent) then
+                     if Is_Predicate_Function (Ent)
+                          or else
+                        Is_Predicate_Function_M (Ent)
+                     then
                         return Stat_Pred (Etype (First_Formal (Ent)));
                      end if;
                   end;