a-except-2005.adb (Rmsg_18): New message text.

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* a-except-2005.adb (Rmsg_18): New message text.
	* a-except.adb (Rmsg_18): New message text.
	* atree.adb (List25): New function
	(Set_List25): New procedure
	* atree.ads (List25): New function
	(Set_List25): New procedure
	* einfo.adb (Static_Predicate): Is now a list
	(OK_To_Reference): Present in all entities
	* einfo.ads (Static_Predicate): Is now a list
	(OK_To_Reference): Applies to all entities
	* exp_ch13.adb (Build_Predicate_Function): Moved to Sem_Ch13
	* sem_attr.adb (Bad_Attribute_For_Predicate): Call
	Bad_Predicated_Subtype_Use.
	* sem_case.ads, sem_case.adb: Major surgery to deal with predicated
	subtype case.
	* sem_ch13.adb (Build_Predicate_Function): Moved from Exp_Ch13 to
	Sem_Ch13.
	(Build_Static_Predicate): New procedure handles static predicates.
	* sem_ch3.adb (Analyze_Subtype_Declaration): Delay freeze on subtype
	with no constraint if ancestor subtype has predicates.
	(Analyze_Variant_Part): New calling sequence for Analyze_Choices
	* sem_ch4.adb (Junk_Operand): Don't complain about OK_To_Reference
	entity.
	(Analyze_Case_Expression): New calling sequence for Analyze_Choices
	* sem_ch5.adb (Analyze_Case_Statement): New calling sequence for
	Analyze_Choices.
	* sem_util.ads, sem_util.adb (Bad_Predicated_Subtype_Use): New procedure
	* types.ads (PE_Bad_Predicated_Generic_Type): Replaces
	PE_Bad_Attribute_For_Predicate.
	* atree.h: Add definition of List25.

From-SVN: r165828

1 files changed, 0 insertions, 329 deletions

diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb
index e977bf9..f3de66c 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.adb
@@ -26,8 +26,6 @@
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
-with Elists;   use Elists;
-with Errout;   use Errout;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Imgv; use Exp_Imgv;
@@ -39,8 +37,6 @@ with Nmake;    use Nmake;
 with Opt;      use Opt;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
-with Sem_Aux;  use Sem_Aux;
-with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch7;  use Sem_Ch7;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Eval; use Sem_Eval;
@@ -54,313 +50,6 @@ with Validsw;  use Validsw;
 
 package body Exp_Ch13 is
 
-   -----------------------
-   -- Local Subprograms --
-   -----------------------
-
-   procedure Build_Predicate_Function
-     (Typ   : Entity_Id;
-      FDecl : out Node_Id;
-      FBody : out Node_Id);
-   --  If Typ has predicates (indicated by Has_Predicates being set for Typ,
-   --  then either there are pragma Invariant entries on the rep chain for the
-   --  type (note that Predicate aspects are converted to pragam Predicate), or
-   --  there are inherited aspects from a parent type, or ancestor subtypes,
-   --  or interfaces. This procedure builds the spec and body for the Predicate
-   --  function that tests these predicates, returning them in PDecl and Pbody
-   --  and setting Predicate_Procedure for Typ. In some error situations no
-   --  procedure is built, in which case PDecl/PBody are empty on return.
-
-   ------------------------------
-   -- Build_Predicate_Function --
-   ------------------------------
-
-   --  The procedure that is constructed here has the form
-
-   --  function typPredicate (Ixxx : typ) return Boolean is
-   --  begin
-   --     return
-   --        exp1 and then exp2 and then ...
-   --        and then typ1Predicate (typ1 (Ixxx))
-   --        and then typ2Predicate (typ2 (Ixxx))
-   --        and then ...;
-   --  end typPredicate;
-
-   --  Here exp1, and exp2 are expressions from Predicate pragmas. Note that
-   --  this is the point at which these expressions get analyzed, providing the
-   --  required delay, and typ1, typ2, are entities from which predicates are
-   --  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;
-      FDecl : out Node_Id;
-      FBody : out Node_Id)
-   is
-      Loc  : constant Source_Ptr := Sloc (Typ);
-      Spec : Node_Id;
-      SId  : Entity_Id;
-
-      Expr : Node_Id;
-      --  This is the expression for the return statement in the function. It
-      --  is build by connecting the component predicates with AND THEN.
-
-      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.
-
-      procedure Add_Predicates;
-      --  Appends expressions for any Predicate pragmas in the rep item chain
-      --  Typ to Expr. Note that we look only at items for this exact entity.
-      --  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
-
-      --------------
-      -- Add_Call --
-      --------------
-
-      procedure Add_Call (T : Entity_Id) is
-         Exp : Node_Id;
-
-      begin
-         if Present (T) and then Present (Predicate_Function (T)) then
-            Set_Has_Predicates (Typ);
-
-            --  Build the call to the predicate function of T
-
-            Exp :=
-              Make_Predicate_Call
-                (T,
-                 Convert_To (T,
-                   Make_Identifier (Loc, Chars => Object_Name)));
-
-            --  Add call to evolving expression, using AND THEN if needed
-
-            if No (Expr) then
-               Expr := Exp;
-            else
-               Expr :=
-                 Make_And_Then (Loc,
-                   Left_Opnd  => Relocate_Node (Expr),
-                   Right_Opnd => Exp);
-            end if;
-
-            --  Output info message on inheritance if required
-
-            if Opt.List_Inherited_Aspects then
-               Error_Msg_Sloc := Sloc (Predicate_Function (T));
-               Error_Msg_Node_2 := T;
-               Error_Msg_N ("?info: & inherits predicate from & #", Typ);
-            end if;
-         end if;
-      end Add_Call;
-
-      --------------------
-      -- Add_Predicates --
-      --------------------
-
-      procedure Add_Predicates is
-         Ritem : Node_Id;
-         Arg1  : Node_Id;
-         Arg2  : Node_Id;
-
-         function Replace_Node (N : Node_Id) return Traverse_Result;
-         --  Process single node for traversal to replace type references
-
-         procedure Replace_Type is new Traverse_Proc (Replace_Node);
-         --  Traverse an expression changing every occurrence of an entity
-         --  reference to type T with a reference to the object argument.
-
-         ------------------
-         -- Replace_Node --
-         ------------------
-
-         function Replace_Node (N : Node_Id) return Traverse_Result is
-         begin
-            --  Case of entity name referencing the type
-
-            if Is_Entity_Name (N) and then Entity (N) = Typ then
-
-               --  Replace with object
-
-               Rewrite (N,
-                 Make_Identifier (Loc,
-                   Chars => Object_Name));
-
-               --  All done with this node
-
-               return Skip;
-
-            --  Not an occurrence of the type entity, keep going
-
-            else
-               return OK;
-            end if;
-         end Replace_Node;
-
-      --  Start of processing for Add_Predicates
-
-      begin
-         Ritem := First_Rep_Item (Typ);
-         while Present (Ritem) loop
-            if Nkind (Ritem) = N_Pragma
-              and then Pragma_Name (Ritem) = Name_Predicate
-            then
-               Arg1 := First (Pragma_Argument_Associations (Ritem));
-               Arg2 := Next (Arg1);
-
-               Arg1 := Get_Pragma_Arg (Arg1);
-               Arg2 := Get_Pragma_Arg (Arg2);
-
-               --  See if this predicate pragma is for the current type
-
-               if Entity (Arg1) = Typ then
-
-                  --  We have a match, this entry is for our subtype
-
-                  --  First We need to replace any occurrences of the name of
-                  --  the type with references to the object. We do this by
-                  --  first doing a preanalysis, to identify all the entities,
-                  --  then we traverse looking for the type entity, doing the
-                  --  needed substitution. The preanalysis is done with the
-                  --  special OK_To_Reference flag set on the type, so that if
-                  --  we get an occurrence of this type, it will be recognized
-                  --  as legitimate.
-
-                  Set_OK_To_Reference (Typ, True);
-                  Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
-                  Set_OK_To_Reference (Typ, False);
-                  Replace_Type (Arg2);
-
-                  --  OK, replacement complete, now we can add the expression
-
-                  if No (Expr) then
-                     Expr := Relocate_Node (Arg2);
-                  else
-                     Expr :=
-                       Make_And_Then (Loc,
-                         Left_Opnd  => Relocate_Node (Expr),
-                         Right_Opnd => Relocate_Node (Arg2));
-                  end if;
-               end if;
-            end if;
-
-            Next_Rep_Item (Ritem);
-         end loop;
-      end Add_Predicates;
-
-   --  Start of processing for Build_Predicate_Function
-
-   begin
-      --  Initialize for construction of statement list
-
-      Expr  := Empty;
-      FDecl := Empty;
-      FBody := Empty;
-
-      --  Return if already built or if type does not have predicates
-
-      if not Has_Predicates (Typ)
-        or else Present (Predicate_Function (Typ))
-      then
-         return;
-      end if;
-
-      --  Add Predicates for the current type
-
-      Add_Predicates;
-
-      --  Add predicates for ancestor if present
-
-      declare
-         Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
-      begin
-         if Present (Atyp) then
-            Add_Call (Atyp);
-         end if;
-      end;
-
-      --  Add predicates of any interfaces of a tagged type
-
-      if Is_Tagged_Type (Typ) then
-         declare
-            Iface_List : Elist_Id;
-            Elmt       : Elmt_Id;
-
-         begin
-            Collect_Interfaces (Typ, Iface_List);
-
-            if Present (Iface_List) then
-               loop
-                  Elmt := First_Elmt (Iface_List);
-                  exit when No (Elmt);
-
-                  Add_Call (Node (Elmt));
-                  Remove_Elmt (Iface_List, Elmt);
-               end loop;
-            end if;
-         end;
-      end if;
-
-      if Present (Expr) then
-
-         --  Build function declaration
-
-         pragma Assert (Has_Predicates (Typ));
-         SId :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_External_Name (Chars (Typ), "Predicate"));
-         Set_Has_Predicates (SId);
-         Set_Predicate_Function (Typ, SId);
-
-         Spec :=
-           Make_Function_Specification (Loc,
-             Defining_Unit_Name       => SId,
-             Parameter_Specifications => New_List (
-               Make_Parameter_Specification (Loc,
-                 Defining_Identifier =>
-                   Make_Defining_Identifier (Loc, Chars => Object_Name),
-                 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, Chars => 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))));
-      end if;
-   end Build_Predicate_Function;
-
    ------------------------------------------
    -- Expand_N_Attribute_Definition_Clause --
    ------------------------------------------
@@ -725,24 +414,6 @@ package body Exp_Ch13 is
          Rewrite (N, Make_Null_Statement (Sloc (N)));
       end if;
 
-      --  If freezing a type entity which has predicates, this is where we
-      --  build and insert the predicate function for the type.
-
-      if Is_Type (E) and then Has_Predicates (E) then
-         declare
-            FDecl : Node_Id;
-            FBody : Node_Id;
-
-         begin
-            Build_Predicate_Function (E, FDecl, FBody);
-
-            if Present (FDecl) then
-               Insert_After (N, FBody);
-               Insert_After (N, FDecl);
-            end if;
-         end;
-      end if;
-
       --  Pop scope if we installed one for the analysis
 
       if In_Other_Scope then