[multiple changes]

2012-10-02  Robert Dewar  <dewar@adacore.com>

	* sem_dim.adb: Minor code reorganization.
	* sem_dim.ads: Add comment.

2012-10-02  Robert Dewar  <dewar@adacore.com>

	* checks.ads, exp_ch4.adb, checks.adb
	(Minimize_Eliminate_Overflow_Checks): Add Top_Level parameter to avoid
	unnecessary conversions to Bignum.
	Minor reformatting.

2012-10-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Process_PPCs): Generate invariant checks for a
	return value whose type is an access type and whose designated
	type has invariants. Ditto for in-out parameters and in-parameters
	of an access type.
	* exp_ch3.adb (Build_Component_Invariant_Call): Add invariant check
	for an access component whose designated type has invariants.

From-SVN: r191956

gcc/ada/ChangeLog

@@ -1,3 +1,24 @@
+2012-10-02  Robert Dewar  <dewar@adacore.com>
+
+	* sem_dim.adb: Minor code reorganization.
+	* sem_dim.ads: Add comment.
+
+2012-10-02  Robert Dewar  <dewar@adacore.com>
+
+	* checks.ads, exp_ch4.adb, checks.adb
+	(Minimize_Eliminate_Overflow_Checks): Add Top_Level parameter to avoid
+	unnecessary conversions to Bignum.
+	Minor reformatting.
+
+2012-10-02  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch6.adb (Process_PPCs): Generate invariant checks for a
+	return value whose type is an access type and whose designated
+	type has invariants. Ditto for in-out parameters and in-parameters
+	of an access type.
+	* exp_ch3.adb (Build_Component_Invariant_Call): Add invariant check
+	for an access component whose designated type has invariants.
+
 2012-10-01  Vincent Pucci  <pucci@adacore.com>
 
 	* sem_aggr.adb (New_Copy_Tree_And_Copy_Dimensions): New routine.

gcc/ada/checks.adb

@@ -1113,8 +1113,11 @@ package body Checks is
 
       --  Otherwise, we have a top level arithmetic operator node, and this
       --  is where we commence the special processing for minimize/eliminate.
+      --  This is the case where we tell the machinery not to move into Bignum
+      --  mode at this top level (of course the top level operation will still
+      --  be in Bignum mode if either of its operands are of type Bignum).
 
-      Minimize_Eliminate_Overflow_Checks (Op, Lo, Hi);
+      Minimize_Eliminate_Overflow_Checks (Op, Lo, Hi, Top_Level => True);
 
       --  That call may but does not necessarily change the result type of Op.
       --  It is the job of this routine to undo such changes, so that at the
@@ -2333,23 +2336,24 @@ package body Checks is
             Error_Msg_N
               ("\this will result in infinite recursion?", Parent (N));
             Insert_Action (N,
-               Make_Raise_Storage_Error
+              Make_Raise_Storage_Error (Sloc (N),
-                 (Sloc (N), Reason => SE_Infinite_Recursion));
+                Reason => SE_Infinite_Recursion));
+
+         --  Here for normal case of predicate active.
 
          else
-
             --  If the predicate is a static predicate and the operand is
             --  static, the predicate must be evaluated statically. If the
             --  evaluation fails this is a static constraint error.
 
             if Is_OK_Static_Expression (N) then
-               if  Present (Static_Predicate (Typ)) then
+               if Present (Static_Predicate (Typ)) then
                   if Eval_Static_Predicate_Check (N, Typ) then
                      return;
                   else
                      Error_Msg_NE
                        ("static expression fails static predicate check on&",
-                          N, Typ);
+                        N, Typ);
                   end if;
                end if;
             end if;
@@ -6549,9 +6553,10 @@ package body Checks is
    ----------------------------------------
 
    procedure Minimize_Eliminate_Overflow_Checks
-     (N  : Node_Id;
+     (N         : Node_Id;
-      Lo : out Uint;
+      Lo        : out Uint;
-      Hi : out Uint)
+      Hi        : out Uint;
+      Top_Level : Boolean)
    is
       pragma Assert (Is_Signed_Integer_Type (Etype (N)));
 
@@ -6578,6 +6583,11 @@ package body Checks is
       OK : Boolean;
       --  Used in call to Determine_Range
 
+      Bignum_Operands : Boolean;
+      --  Set True if one or more operands is already of type Bignum, meaning
+      --  that for sure (regardless of Top_Level setting) we are committed to
+      --  doing the operation in Bignum mode.
+
       procedure Max (A : in out Uint; B : Uint);
       --  If A is No_Uint, sets A to B, else to UI_Max (A, B);
 
@@ -6609,7 +6619,7 @@ package body Checks is
    --  Start of processing for Minimize_Eliminate_Overflow_Checks
 
    begin
-      --  Case where we do not have an arithmetic operator.
+      --  Case where we do not have an arithmetic operator
 
       if not Is_Signed_Integer_Arithmetic_Op (N) then
 
@@ -6638,10 +6648,12 @@ package body Checks is
       --  that lies below us!)
 
       else
-         Minimize_Eliminate_Overflow_Checks (Right_Opnd (N), Rlo, Rhi);
+         Minimize_Eliminate_Overflow_Checks
+           (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
 
          if Binary then
-            Minimize_Eliminate_Overflow_Checks (Left_Opnd (N), Llo, Lhi);
+            Minimize_Eliminate_Overflow_Checks
+              (Left_Opnd (N), Llo, Lhi, Top_Level => False);
          end if;
       end if;
 
@@ -6650,10 +6662,13 @@ package body Checks is
       if Rlo = No_Uint or else (Binary and then Llo = No_Uint) then
          Lo := No_Uint;
          Hi := No_Uint;
+         Bignum_Operands := True;
 
       --  Otherwise compute result range
 
       else
+         Bignum_Operands := False;
+
          case Nkind (N) is
 
             --  Absolute value
@@ -7007,14 +7022,33 @@ package body Checks is
 
       if Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
 
-         --  In MINIMIZED mode, note that an overflow check is required
+         --  OK, we are definitely outside the range of Long_Long_Integer. The
-         --  Note that we know we don't have a Bignum, since Bignums only
+         --  question is whether to move into Bignum mode, or remain the domain
-         --  appear in Eliminated mode.
+         --  of Long_Long_Integer, signalling that an overflow check is needed.
 
-         if Check_Mode = Minimized then
+         --  Obviously in MINIMIZED mode we stay with LLI, since we are not in
+         --  the Bignum business. In ELIMINATED mode, we will normally move
+         --  into Bignum mode, but there is an exception if neither of our
+         --  operands is Bignum now, and we are at the top level (Top_Level
+         --  set True). In this case, there is no point in moving into Bignum
+         --  mode to prevent overflow if the caller will immediately convert
+         --  the Bignum value back to LLI with an overflow check. It's more
+         --  efficient to stay in LLI mode with an overflow check.
+
+         if Check_Mode = Minimized
+           or else (Top_Level and not Bignum_Operands)
+         then
             Enable_Overflow_Check (N);
 
-         --  Otherwise we are in ELIMINATED mode, switch to bignum
+            --  Since we are doing an overflow check, the result has to be in
+            --  Long_Long_Integer mode, so adjust the possible range to reflect
+            --  this. Note these calls also change No_Uint values from the top
+            --  level case to LLI bounds.
+
+            Max (Lo, LLLo);
+            Min (Hi, LLHi);
+
+         --  Otherwise we are in ELIMINATED mode and we switch to Bignum mode
 
          else
             pragma Assert (Check_Mode = Eliminated);
@@ -7079,6 +7113,11 @@ package body Checks is
                    Name                   => New_Occurrence_Of (Fent, Loc),
                    Parameter_Associations => Args));
                Analyze_And_Resolve (N, RTE (RE_Bignum));
+
+               --  Indicate result is Bignum mode
+
+               Lo := No_Uint;
+               Hi := No_Uint;
                return;
             end;
          end if;

gcc/ada/checks.ads

@@ -260,9 +260,10 @@ package Checks is
    --  parameter is used to supply Sloc values for the constructed tree.
 
    procedure Minimize_Eliminate_Overflow_Checks
-     (N  : Node_Id;
+     (N         : Node_Id;
-      Lo : out Uint;
+      Lo        : out Uint;
-      Hi : out Uint);
+      Hi        : out Uint;
+      Top_Level : Boolean);
    --  This is the main routine for handling MINIMIZED and ELIMINATED overflow
    --  checks. On entry N is a node whose result is a signed integer subtype.
    --  If the node is an artihmetic operation, then a range analysis is carried
@@ -321,6 +322,16 @@ package Checks is
    --
    --  Note that if Bignum values appear, the caller must take care of doing
    --  the appropriate mark/release operation on the secondary stack.
+   --
+   --  Top_Level is used to avoid inefficient unnecessary transitions into the
+   --  Bignum domain. If Top_Level is True, it means that the caller will have
+   --  to convert any Bignum value back to Long_Long_Integer, checking that the
+   --  value is in range. This is the normal case for a top level operator in
+   --  a subexpression. There is no point in going into Bignum mode to avoid an
+   --  overflow just so we can check for overflow the next moment. For calls
+   --  from comparisons and membership tests, and for all recursive calls, we
+   --  do want to transition into the Bignum domain if necessary. Note that
+   --  this setting is only relevant in ELIMINATED mode.
 
    -------------------------------------------------------
    -- Control and Optimization of Range/Overflow Checks --

gcc/ada/exp_ch3.adb

@@ -3674,20 +3674,43 @@ package body Exp_Ch3 is
       return Node_Id
       is
          Sel_Comp : Node_Id;
+         Typ      : Entity_Id;
+         Call     : Node_Id;
 
       begin
          Invariant_Found := True;
+         Typ := Etype (Comp);
+
          Sel_Comp :=
            Make_Selected_Component (Loc,
              Prefix      => New_Occurrence_Of (Object_Entity, Loc),
              Selector_Name => New_Occurrence_Of (Comp, Loc));
 
-         return
+         if Is_Access_Type (Typ) then
+            Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp);
+            Typ := Designated_Type (Typ);
+         end if;
+
+         Call :=
            Make_Procedure_Call_Statement (Loc,
              Name                   =>
-               New_Occurrence_Of
+               New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
-                 (Invariant_Procedure (Etype (Comp)), Loc),
              Parameter_Associations => New_List (Sel_Comp));
+
+         if Is_Access_Type (Etype (Comp)) then
+            Call :=
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Op_Ne (Loc,
+                    Left_Opnd   => Make_Null (Loc),
+                    Right_Opnd  =>
+                       Make_Selected_Component (Loc,
+                         Prefix      => New_Occurrence_Of (Object_Entity, Loc),
+                         Selector_Name => New_Occurrence_Of (Comp, Loc))),
+                Then_Statements => New_List (Call));
+         end if;
+
+         return Call;
       end Build_Component_Invariant_Call;
 
       ----------------------------
@@ -3706,7 +3729,16 @@ package body Exp_Ch3 is
             if Nkind (Decl) = N_Component_Declaration then
                Id  := Defining_Identifier (Decl);
 
-               if Has_Invariants (Etype (Id)) then
+               if Has_Invariants (Etype (Id))
+                 and then In_Open_Scopes (Scope (R_Type))
+               then
+                  Append_To (Stmts, Build_Component_Invariant_Call (Id));
+
+               elsif Is_Access_Type (Etype (Id))
+                 and then not Is_Access_Constant (Etype (Id))
+                 and then Has_Invariants (Designated_Type (Etype (Id)))
+                 and then In_Open_Scopes (Scope (Designated_Type (Etype (Id))))
+               then
                   Append_To (Stmts, Build_Component_Invariant_Call (Id));
                end if;
             end if;
@@ -5861,9 +5893,14 @@ package body Exp_Ch3 is
          Build_Array_Init_Proc (Base, N);
       end if;
 
-      if Has_Invariants (Component_Type (Base)) then
+      if Has_Invariants (Component_Type (Base))
-
+        and then In_Open_Scopes (Scope (Component_Type (Base)))
-         --  Generate component invariant checking procedure.
+      then
+         --  Generate component invariant checking procedure. This is only
+         --  relevant if the array type is within the scope of the component
+         --  type. Otherwise an array object can only be built using the public
+         --  subprograms for the component type, and calls to those will have
+         --  invariant checks.
 
          Insert_Component_Invariant_Checks
            (N, Base, Build_Array_Invariant_Proc (Base, N));

gcc/ada/exp_ch4.adb

@@ -2345,8 +2345,10 @@ package body Exp_Ch4 is
       --  our operands using the Minimize_Eliminate circuitry which applies
       --  this processing to the two operand subtrees.
 
-      Minimize_Eliminate_Overflow_Checks (Left_Opnd (N),  Llo, Lhi);
+      Minimize_Eliminate_Overflow_Checks
-      Minimize_Eliminate_Overflow_Checks (Right_Opnd (N), Rlo, Rhi);
+        (Left_Opnd (N),  Llo, Lhi, Top_Level => False);
+      Minimize_Eliminate_Overflow_Checks
+        (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
 
       --  See if the range information decides the result of the comparison
 
@@ -3735,7 +3737,7 @@ package body Exp_Ch4 is
       --  Entity for Long_Long_Integer'Base (Standard should export this???)
 
    begin
-      Minimize_Eliminate_Overflow_Checks (Lop, Lo, Hi);
+      Minimize_Eliminate_Overflow_Checks (Lop, Lo, Hi, Top_Level => False);
 
       --  If right operand is a subtype name, and the subtype name has no
       --  predicate, then we can just replace the right operand with an
@@ -3760,8 +3762,10 @@ package body Exp_Ch4 is
       --  have not been processed for minimized or eliminated checks.
 
       if Nkind (Rop) = N_Range then
-         Minimize_Eliminate_Overflow_Checks (Low_Bound (Rop),  Lo, Hi);
+         Minimize_Eliminate_Overflow_Checks
-         Minimize_Eliminate_Overflow_Checks (High_Bound (Rop), Lo, Hi);
+           (Low_Bound (Rop),  Lo, Hi, Top_Level => False);
+         Minimize_Eliminate_Overflow_Checks
+           (High_Bound (Rop), Lo, Hi, Top_Level => False);
 
          --  We have A in B .. C, treated as  A >= B and then A <= C
 

gcc/ada/sem_aggr.adb

@@ -4080,6 +4080,7 @@ package body Sem_Aggr is
                      --  We build a partially initialized aggregate with the
                      --  values of the discriminants and box initialization
                      --  for the rest, if other components are present.
+
                      --  The type of the aggregate is the known subtype of
                      --  the component. The capture of discriminants must
                      --  be recursive because subcomponents may be constrained
@@ -4434,9 +4435,8 @@ package body Sem_Aggr is
                   Next (New_Assoc);
                end loop;
 
-               --  If no association, this is not a legal component of
+               --  If no association, this is not a legal component of the type
-               --  of the type in question, except if its association
+               --  in question, unless its association is provided with a box.
-               --  is provided with a box.
 
                if No (New_Assoc) then
                   if Box_Present (Parent (Selectr)) then

gcc/ada/sem_ch6.adb

@@ -11078,6 +11078,12 @@ package body Sem_Ch6 is
       Plist : List_Id := No_List;
       --  List of generated postconditions
 
+      procedure Check_Access_Invariants (E : Entity_Id);
+      --  If the subprogram returns an access to a type with invariants, or
+      --  has access parameters whose designated type has an invariant, then
+      --  under the same visibility conditions as for other invariant checks,
+      --  the type invariant must be applied to the returned value.
+
       function Grab_CC return Node_Id;
       --  Prag contains an analyzed contract case pragma. This function copies
       --  relevant components of the pragma, creates the corresponding Check
@@ -11108,6 +11114,43 @@ package body Sem_Ch6 is
       --  that an invariant check is required (for an IN OUT parameter, or
       --  the returned value of a function.
 
+      -----------------------------
+      -- Check_Access_Invariants --
+      -----------------------------
+
+      procedure Check_Access_Invariants (E : Entity_Id) is
+         Call : Node_Id;
+         Obj  : Node_Id;
+         Typ  : Entity_Id;
+
+      begin
+         if Is_Access_Type (Etype (E))
+           and then not Is_Access_Constant (Etype (E))
+         then
+            Typ := Designated_Type (Etype (E));
+
+            if Has_Invariants (Typ)
+              and then Present (Invariant_Procedure (Typ))
+              and then Is_Public_Subprogram_For (Typ)
+            then
+               Obj :=
+                 Make_Explicit_Dereference (Loc,
+                   Prefix => New_Occurrence_Of (E, Loc));
+               Set_Etype (Obj, Typ);
+
+               Call := Make_Invariant_Call (Obj);
+
+               Append_To (Plist,
+                 Make_If_Statement (Loc,
+                   Condition =>
+                     Make_Op_Ne (Loc,
+                       Left_Opnd   => Make_Null (Loc),
+                       Right_Opnd  => New_Occurrence_Of (E, Loc)),
+                   Then_Statements => New_List (Call)));
+            end if;
+         end if;
+      end Check_Access_Invariants;
+
       -------------
       -- Grab_CC --
       -------------
@@ -11308,12 +11351,19 @@ package body Sem_Ch6 is
          Formal : Entity_Id;
 
       begin
-         --  Check function return result
+         --  Check function return result. If result is an access type there
+         --  may be invariants on the designated type.
 
          if Ekind (Designator) /= E_Procedure
            and then Has_Invariants (Etype (Designator))
          then
             return True;
+
+         elsif Ekind (Designator) /= E_Procedure
+           and then Is_Access_Type (Etype (Designator))
+           and then Has_Invariants (Designated_Type (Etype (Designator)))
+         then
+            return True;
          end if;
 
          --  Check parameters
@@ -11321,9 +11371,13 @@ package body Sem_Ch6 is
          Formal := First_Formal (Designator);
          while Present (Formal) loop
             if Ekind (Formal) /= E_In_Parameter
-              and then
+              and then (Has_Invariants (Etype (Formal))
-                (Has_Invariants (Etype (Formal))
+                         or else Present (Predicate_Function (Etype (Formal))))
-                  or else Present (Predicate_Function (Etype (Formal))))
+            then
+               return True;
+
+            elsif Is_Access_Type (Etype (Formal))
+              and then Has_Invariants (Designated_Type (Etype (Formal)))
             then
                return True;
             end if;
@@ -11731,6 +11785,10 @@ package body Sem_Ch6 is
                   Append_To (Plist,
                     Make_Invariant_Call (New_Occurrence_Of (Rent, Loc)));
                end if;
+
+               --  Same if return value is an access to type with invariants.
+
+               Check_Access_Invariants (Rent);
             end;
 
          --  Procedure rather than a function
@@ -11750,7 +11808,9 @@ package body Sem_Ch6 is
          begin
             Formal := First_Formal (Designator);
             while Present (Formal) loop
-               if Ekind (Formal) /= E_In_Parameter then
+               if Ekind (Formal) /= E_In_Parameter
+                 or else Is_Access_Type (Etype (Formal))
+               then
                   Ftype := Etype (Formal);
 
                   if Has_Invariants (Ftype)
@@ -11762,6 +11822,8 @@ package body Sem_Ch6 is
                          (New_Occurrence_Of (Formal, Loc)));
                   end if;
 
+                  Check_Access_Invariants (Formal);
+
                   if Present (Predicate_Function (Ftype)) then
                      Append_To (Plist,
                        Make_Predicate_Check

gcc/ada/sem_dim.adb

@@ -2206,13 +2206,14 @@ package body Sem_Dim is
       Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
 
    begin
+      --  Ignore if not Ada 2012 or beyond
+
       if Ada_Version < Ada_2012 then
          return;
-      end if;
 
-      --  Copy the dimension of 'From to 'To'
+      --  For Ada 2012, Copy the dimension of 'From to 'To'
 
-      if Exists (Dims_Of_From) then
+      elsif Exists (Dims_Of_From) then
          Set_Dimensions (To, Dims_Of_From);
       end if;
    end Copy_Dimensions;
@@ -2730,14 +2731,14 @@ package body Sem_Dim is
          --  Look for a symbols parameter association in the list of actuals
 
          while Present (Actual) loop
+
             --  Positional parameter association case when the actual is a
             --  string literal.
 
             if Nkind (Actual) = N_String_Literal then
                Actual_Str := Actual;
 
-            --  Named parameter association case when the selector name is
+            --  Named parameter association case when selector name is Symbol
-            --  Symbol.
 
             elsif Nkind (Actual) = N_Parameter_Association
               and then Chars (Selector_Name (Actual)) = Name_Symbol
@@ -2751,6 +2752,7 @@ package body Sem_Dim is
             end if;
 
             if Present (Actual_Str) then
+
                --  Return True if the actual comes from source or if the string
                --  of symbols doesn't have the default value (i.e. it is "").
 
@@ -3206,7 +3208,8 @@ package body Sem_Dim is
 
       return
         Is_RTU (E, System_Dim_Float_IO)
-          or Is_RTU (E, System_Dim_Integer_IO);
+          or else
+        Is_RTU (E, System_Dim_Integer_IO);
    end Is_Dim_IO_Package_Entity;
 
    -------------------------------------

gcc/ada/sem_dim.ads

@@ -163,7 +163,8 @@ package Sem_Dim is
    --  literal default value in the list of formals Formals.
 
    procedure Copy_Dimensions (From, To : Node_Id);
-   --  Copy dimension vector of From to To.
+   --  Copy dimension vector of From to To
+   --  We should say what the requirements on From and To are here ???
 
    procedure Eval_Op_Expon_For_Dimensioned_Type
      (N    : Node_Id;

gcc/ada/sem_eval.adb

@@ -3260,6 +3260,7 @@ package body Sem_Eval is
       Loc  : constant Source_Ptr := Sloc (N);
       Pred : constant List_Id := Static_Predicate (Typ);
       Test : Node_Id;
+
    begin
       if No (Pred) then
          return True;

gcc/ada/sem_eval.ads

@@ -320,7 +320,7 @@ package Sem_Eval is
    function Eval_Static_Predicate_Check
      (N  : Node_Id;
      Typ : Entity_Id) return Boolean;
-   --  Evaluate a static predicate check applied to a scalar literal.
+   --  Evaluate a static predicate check applied to a scalar literal
 
    procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
    --  Rewrite N with a new N_String_Literal node as the result of the compile