[multiple changes]

2014-07-31  Robert Dewar  <dewar@adacore.com>

	* exp_util.adb, lib-writ.adb, sem_ch12.adb, s-direio.adb: Minor
	reformatting.

2014-07-31  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_attr.adb (Expand_Loop_Entry_Attribute): Update the comment
	which demonstrates the expansion of while loops subject to
	attribute 'Loop_Entry. The condition of a while loop along with
	related condition actions is now wrapped in a function.  Instead
	of repeating the condition, the expansion now calls the function.

2014-07-31  Ed Schonberg  <schonberg@adacore.com>

	* sem_case.adb (Check_Against_Predicate): Correct off-by-one
	error when reporting of missing values in a case statement for
	a type with a static predicate.
	(Check_Choices): Reject a choice given by a subtype to which a
	Dynamic_Predicate applies.
	* sem_ch3.adb (Analyze_Subtype_Declaration): Inherit
	Has_Dynamic_Predicate_Aspect flag from parent.

2014-07-31  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): A predicate
	cannot apply to a subtype of an incomplete type.
	(Is_Static_Choice): Treat an Others_Clause as static. The
	staticness of the expression and of the range are checked
	elsewhere.

2014-07-31  Pascal Obry  <obry@adacore.com>

	* adaint.h (__gnat_ftell64): Added.
	(__gnat_fseek64): Added.
	(__int64): Added.
	* cstreams.c (__int64): Removed.

From-SVN: r213366

gcc/ada/ChangeLog

+2014-07-31  Robert Dewar  <dewar@adacore.com>
+
+	* exp_util.adb, lib-writ.adb, sem_ch12.adb, s-direio.adb: Minor
+	reformatting.
+
+2014-07-31  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_attr.adb (Expand_Loop_Entry_Attribute): Update the comment
+	which demonstrates the expansion of while loops subject to
+	attribute 'Loop_Entry. The condition of a while loop along with
+	related condition actions is now wrapped in a function.  Instead
+	of repeating the condition, the expansion now calls the function.
+
+2014-07-31  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_case.adb (Check_Against_Predicate): Correct off-by-one
+	error when reporting of missing values in a case statement for
+	a type with a static predicate.
+	(Check_Choices): Reject a choice given by a subtype to which a
+	Dynamic_Predicate applies.
+	* sem_ch3.adb (Analyze_Subtype_Declaration): Inherit
+	Has_Dynamic_Predicate_Aspect flag from parent.
+
+2014-07-31  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch13.adb (Analyze_Aspect_Specifications): A predicate
+	cannot apply to a subtype of an incomplete type.
+	(Is_Static_Choice): Treat an Others_Clause as static. The
+	staticness of the expression and of the range are checked
+	elsewhere.
+
+2014-07-31  Pascal Obry  <obry@adacore.com>
+
+	* adaint.h (__gnat_ftell64): Added.
+	(__gnat_fseek64): Added.
+	(__int64): Added.
+	* cstreams.c (__int64): Removed.
+
 2014-07-31  Pascal Obry  <obry@adacore.com>
 
 	* a-stream.ads (Stream_Element_Offset): Now a signed 64bit type.

gcc/ada/adaint.h

@@ -72,6 +72,8 @@ typedef long long OS_Time;
 typedef long OS_Time;
 #endif
 
+#define __int64 long long
+
 /* A lazy cache for the attributes of a file. On some systems, a single call to
    stat() will give all this information, so it is better than doing a system
    call every time. On other systems this require several system calls.
@@ -251,6 +253,10 @@ extern int    __gnat_set_close_on_exec		   (int, int);
 extern int    __gnat_dup			   (int);
 extern int    __gnat_dup2			   (int, int);
 
+/* large file support */
+extern __int64 __gnat_ftell64                      (FILE *);
+extern int     __gnat_fseek64                      (FILE *, __int64, int);
+
 extern int    __gnat_number_of_cpus                (void);
 
 extern void   __gnat_os_filename                   (char *, char *, char *,

gcc/ada/cstreams.c

@@ -253,8 +253,6 @@ __gnat_full_name (char *nam, char *buffer)
   return buffer;
 }
 
-#define __int64 long long
-
 #ifdef _WIN32
   /* On Windows we want to use the fseek/fteel supporting large files. This
      issue is due to the fact that a long on Win64 is still a 32 bits value */

gcc/ada/exp_attr.adb

@@ -1120,7 +1120,13 @@ package body Exp_Attr is
 
          --  While loops are transformed into:
 
-         --    if <Condition> then
+         --    function Fnn return Boolean is
+         --    begin
+         --       <condition actions>
+         --       return <condition>;
+         --    end Fnn;
+
+         --    if Fnn then
          --       declare
          --          Temp1 : constant <type of Pref1> := <Pref1>;
          --          . . .
@@ -1128,7 +1134,7 @@ package body Exp_Attr is
          --       begin
          --          loop
          --             <original source statements with attribute rewrites>
-         --             exit when not <Condition>;
+         --             exit when not Fnn;
          --          end loop;
          --       end;
          --    end if;
@@ -1138,23 +1144,81 @@ package body Exp_Attr is
 
          elsif Present (Condition (Scheme)) then
             declare
-               Cond : constant Node_Id := Condition (Scheme);
+               Func_Decl : Node_Id;
+               Func_Id   : Entity_Id;
+               Stmts     : List_Id;
 
             begin
+               --  Wrap the condition of the while loop in a Boolean function.
+               --  This avoids the duplication of the same code which may lead
+               --  to gigi issues with respect to multiple declaration of the
+               --  same entity in the presence of side effects or checks. Note
+               --  that the condition actions must also be relocated to the
+               --  wrapping function.
+
+               --  Generate:
+               --    <condition actions>
+               --    return <condition>;
+
+               if Present (Condition_Actions (Scheme)) then
+                  Stmts := Condition_Actions (Scheme);
+               else
+                  Stmts := New_List;
+               end if;
+
+               Append_To (Stmts,
+                 Make_Simple_Return_Statement (Loc,
+                   Expression => Relocate_Node (Condition (Scheme))));
+
+               --  Generate:
+               --    function Fnn return Boolean is
+               --    begin
+               --       <Stmts>
+               --    end Fnn;
+
+               Func_Id   := Make_Temporary (Loc, 'F');
+               Func_Decl :=
+                 Make_Subprogram_Body (Loc,
+                   Specification              =>
+                     Make_Function_Specification (Loc,
+                       Defining_Unit_Name => Func_Id,
+                       Result_Definition  =>
+                         New_Occurrence_Of (Standard_Boolean, Loc)),
+                   Declarations               => Empty_List,
+                   Handled_Statement_Sequence =>
+                     Make_Handled_Sequence_Of_Statements (Loc,
+                       Statements => Stmts));
+
+               --  The function is inserted before the related loop. Make sure
+               --  to analyze it in the context of the loop's enclosing scope.
+
+               Push_Scope (Scope (Loop_Id));
+               Insert_Action (Loop_Stmt, Func_Decl);
+               Pop_Scope;
+
                --  Transform the original while loop into an infinite loop
                --  where the last statement checks the negated condition. This
                --  placement ensures that the condition will not be evaluated
                --  twice on the first iteration.
 
+               Set_Iteration_Scheme (Loop_Stmt, Empty);
+               Scheme := Empty;
+
                --  Generate:
-               --    exit when not <Cond>:
+               --    exit when not Fnn;
 
                Append_To (Statements (Loop_Stmt),
                  Make_Exit_Statement (Loc,
-                   Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond))));
+                   Condition =>
+                     Make_Op_Not (Loc,
+                       Right_Opnd =>
+                         Make_Function_Call (Loc,
+                           Name => New_Occurrence_Of (Func_Id, Loc)))));
 
                Build_Conditional_Block (Loc,
-                 Cond      => Relocate_Node (Cond),
+                 Cond      =>
+                   Make_Function_Call (Loc,
+                     Name => New_Occurrence_Of (Func_Id, Loc)),
                  Loop_Stmt => Relocate_Node (Loop_Stmt),
                  If_Stmt   => Result,
                  Blk_Stmt  => Blk);
@@ -1289,8 +1353,6 @@ package body Exp_Attr is
 
       --  Step 4: Analyze all bits
 
-      Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
-
       Installed := Current_Scope = Scope (Loop_Id);
 
       --  Depending on the pracement of attribute 'Loop_Entry relative to the
@@ -1305,19 +1367,6 @@ package body Exp_Attr is
 
       if Present (Result) then
          Rewrite (Loop_Stmt, Result);
-
-         --  The insertion of condition actions associated with an iteration
-         --  scheme is usually done by the expansion of loop statements. The
-         --  expansion of Loop_Entry however reuses the iteration scheme to
-         --  build an if statement. As a result any condition actions must be
-         --  inserted before the if statement to avoid references before
-         --  declaration.
-
-         if Present (Scheme) and then Present (Condition_Actions (Scheme)) then
-            Insert_Actions (Loop_Stmt, Condition_Actions (Scheme));
-            Set_Condition_Actions (Scheme, No_List);
-         end if;
-
          Analyze (Loop_Stmt);
 
       --  The conditional block was analyzed when a previous 'Loop_Entry was
@@ -1328,6 +1377,7 @@ package body Exp_Attr is
          Analyze (Temp_Decl);
       end if;
 
+      Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
       Analyze (N);
 
       if not Installed then

gcc/ada/exp_util.adb

@@ -3325,7 +3325,6 @@ package body Exp_Util is
    function Has_Annotate_Pragma_For_External_Axiomatization
      (E : Entity_Id) return Boolean
    is
-
       function Is_Annotate_Pragma_For_External_Axiomatization
         (N : Node_Id) return Boolean;
       --  Returns whether N is
@@ -3352,15 +3351,14 @@ package body Exp_Util is
       --    pragma Annotate (GNATprove, External_Axiomatization);
 
       function Is_Annotate_Pragma_For_External_Axiomatization
-        (N : Node_Id) return Boolean is
-
-         -------------------
-         -- Special Names --
-         -------------------
-
-         Name_GNATprove : constant String := "gnatprove";
+        (N : Node_Id) return Boolean
+      is
+         Name_GNATprove               : constant String :=
+                                          "gnatprove";
          Name_External_Axiomatization : constant String :=
-           "external_axiomatization";
+                                          "external_axiomatization";
+         --  Special names
+
       begin
          if Nkind (N) = N_Pragma
            and then Get_Pragma_Id (Pragma_Name (N)) = Pragma_Annotate
@@ -3368,10 +3366,11 @@ package body Exp_Util is
          then
             declare
                Arg1 : constant Node_Id :=
-                 First (Pragma_Argument_Associations (N));
+                        First (Pragma_Argument_Associations (N));
                Arg2 : constant Node_Id := Next (Arg1);
                Nam1 : Name_Id;
                Nam2 : Name_Id;
+
             begin
                --  Fill in Name_Buffer with Name_GNATprove first, and then with
                --  Name_External_Axiomatization so that Name_Find returns the
@@ -3386,8 +3385,8 @@ package body Exp_Util is
                Nam2 := Name_Find;
 
                return Chars (Get_Pragma_Arg (Arg1)) = Nam1
-                 and then
-                   Chars (Get_Pragma_Arg (Arg2)) = Nam2;
+                         and then
+                      Chars (Get_Pragma_Arg (Arg2)) = Nam2;
             end;
 
          else
@@ -3395,10 +3394,14 @@ package body Exp_Util is
          end if;
       end Is_Annotate_Pragma_For_External_Axiomatization;
 
-      Decl : Node_Id;
+      --  Local variables
+
+      Decl      : Node_Id;
       Vis_Decls : List_Id;
       N         : Node_Id;
 
+   --  Start of processing for Has_Annotate_Pragma_For_External_Axiomatization
+
    begin
       if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
          Decl := Parent (Parent (E));

gcc/ada/lib-writ.adb

@@ -662,8 +662,7 @@ package body Lib.Writ is
                --  compilation unit.
 
             begin
-               if U /= No_Unit
-                 and then Nkind (Unit (Cunit (U))) = N_Subunit
+               if U /= No_Unit and then Nkind (Unit (Cunit (U))) = N_Subunit
                then
                   Note_Unit := Main_Unit;
                else

gcc/ada/s-direio.adb

@@ -282,8 +282,9 @@ package body System.Direct_IO is
    procedure Set_Position (File : File_Type) is
       R : int;
    begin
-      R := fseek64
-        (File.Stream, int64 (File.Bytes) * int64 (File.Index - 1), SEEK_SET);
+      R :=
+        fseek64
+          (File.Stream, int64 (File.Bytes) * int64 (File.Index - 1), SEEK_SET);
 
       if R /= 0 then
          raise Use_Error;
@@ -296,6 +297,7 @@ package body System.Direct_IO is
 
    function Size (File : File_Type) return Count is
       Pos : int64;
+
    begin
       FIO.Check_File_Open (AP (File));
       File.Last_Op := Op_Other;

gcc/ada/sem_case.adb

@@ -433,9 +433,10 @@ package body Sem_Case is
                   Error := True;
 
                --  The previous choice covered part of the static predicate set
+               --  but there is a gap after Prev_Hi.
 
                else
-                  Missing_Choice (Prev_Hi, Choice_Lo - 1);
+                  Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
                   Error := True;
                end if;
             end if;
@@ -1462,6 +1463,7 @@ package body Sem_Case is
 
                            if not Is_Discrete_Type (E)
                              or else not Has_Static_Predicate (E)
+                             or else Has_Dynamic_Predicate_Aspect (E)
                            then
                               Bad_Predicated_Subtype_Use
                                 ("cannot use subtype& with non-static "

gcc/ada/sem_ch12.adb

@@ -1018,17 +1018,17 @@ package body Sem_Ch12 is
         (Formal : Entity_Id;
          Actual : Entity_Id := Empty) return Node_Id
       is
-         Loc     : constant Source_Ptr := Sloc (I_Node);
-         Typ     : constant Entity_Id := Etype (Formal);
+         Loc       : constant Source_Ptr := Sloc (I_Node);
+         Typ       : constant Entity_Id := Etype (Formal);
          Is_Binary : constant Boolean :=
-                        Present (Next_Formal (First_Formal (Formal)));
+                       Present (Next_Formal (First_Formal (Formal)));
 
-         Decl   : Node_Id;
-         Expr   : Node_Id;
-         F1, F2 : Entity_Id;
-         Func   : Entity_Id;
+         Decl    : Node_Id;
+         Expr    : Node_Id;
+         F1, F2  : Entity_Id;
+         Func    : Entity_Id;
          Op_Name : Name_Id;
-         Spec   : Node_Id;
+         Spec    : Node_Id;
 
          L, R   : Node_Id;
 
@@ -1050,23 +1050,24 @@ package body Sem_Ch12 is
          Set_Ekind (Func, E_Function);
          Set_Is_Generic_Actual_Subprogram (Func);
 
-         Spec := Make_Function_Specification (Loc,
-            Defining_Unit_Name => Func,
-
-            Parameter_Specifications => New_List (
-              Make_Parameter_Specification (Loc,
-                Defining_Identifier => F1,
-                Parameter_Type => Make_Identifier
-                  (Loc, Chars (Etype (First_Formal (Formal)))))),
-
-            Result_Definition => Make_Identifier (Loc, Chars (Typ)));
+         Spec :=
+           Make_Function_Specification (Loc,
+             Defining_Unit_Name       => Func,
+             Parameter_Specifications => New_List (
+               Make_Parameter_Specification (Loc,
+                  Defining_Identifier => F1,
+                  Parameter_Type      =>
+                    Make_Identifier (Loc,
+                      Chars => Chars (Etype (First_Formal (Formal)))))),
+             Result_Definition        => Make_Identifier (Loc, Chars (Typ)));
 
          if Is_Binary then
             Append_To (Parameter_Specifications (Spec),
                Make_Parameter_Specification (Loc,
                  Defining_Identifier => F2,
-                 Parameter_Type => Make_Identifier (Loc,
-                   Chars (Etype (Next_Formal (First_Formal (Formal)))))));
+                 Parameter_Type =>
+                   Make_Identifier (Loc,
+                     Chars (Etype (Next_Formal (First_Formal (Formal)))))));
          end if;
 
          --  Build expression as a function call, or as an operator node
@@ -1074,86 +1075,73 @@ package body Sem_Ch12 is
          --  operators.
 
          if Present (Actual) and then Op_Name not in Any_Operator_Name then
-            Expr := Make_Function_Call (Loc,
-                      Name => New_Occurrence_Of (Entity (Actual), Loc),
-                      Parameter_Associations => New_List (L));
+            Expr :=
+              Make_Function_Call (Loc,
+                Name                   =>
+                  New_Occurrence_Of (Entity (Actual), Loc),
+                Parameter_Associations => New_List (L));
 
             if Is_Binary then
                Append_To (Parameter_Associations (Expr), R);
             end if;
 
+         --  Binary operators
+
          elsif Is_Binary then
             if Op_Name = Name_Op_And then
                Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Or then
                Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Xor then
                Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Eq then
                Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Ne then
                Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Le then
                Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Gt then
                Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Ge then
                Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Lt then
                Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Add then
                Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Subtract then
                Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Concat then
                Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Multiply then
                Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Divide then
                Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Mod then
                Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Rem then
                Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R);
-
             elsif Op_Name = Name_Op_Expon then
                Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R);
             end if;
 
-         else    --  Unary operators.
+         --  Unary operators
 
+         else
             if Op_Name = Name_Op_Add then
                Expr := Make_Op_Plus (Loc, Right_Opnd => L);
-
             elsif Op_Name = Name_Op_Subtract then
                Expr := Make_Op_Minus (Loc, Right_Opnd => L);
-
             elsif Op_Name = Name_Op_Abs then
                Expr := Make_Op_Abs (Loc, Right_Opnd => L);
-
             elsif Op_Name = Name_Op_Not then
                Expr := Make_Op_Not (Loc, Right_Opnd => L);
             end if;
          end if;
 
-         Decl := Make_Expression_Function (Loc,
-                    Specification => Spec,
-                    Expression => Expr);
+         Decl :=
+           Make_Expression_Function (Loc,
+             Specification => Spec,
+             Expression    => Expr);
 
          return Decl;
       end Build_Wrapper;

gcc/ada/sem_ch13.adb

@@ -1787,6 +1787,11 @@ package body Sem_Ch13 is
                        ("predicate can only be specified for a subtype",
                         Aspect);
                      goto Continue;
+
+                  elsif Is_Incomplete_Type (E) then
+                     Error_Msg_N
+                       ("predicate cannot apply to incomplete view", Aspect);
+                     goto Continue;
                   end if;
 
                   --  Construct the pragma (always a pragma Predicate, with
@@ -3544,8 +3549,9 @@ package body Sem_Ch13 is
             if Ekind (Current_Scope) = E_Package
               and then Has_Private_Declaration (Ent)
               and then From_Aspect_Specification (N)
-              and then List_Containing (Parent (Ent))
-                 = Private_Declarations
+              and then
+                List_Containing (Parent (Ent)) =
+                  Private_Declarations
                     (Specification (Unit_Declaration_Node (Current_Scope)))
               and then Nkind (N) = N_Attribute_Definition_Clause
             then
@@ -3555,8 +3561,8 @@ package body Sem_Ch13 is
                begin
                   Decl :=
                      First (Visible_Declarations
-                      (Specification
-                        (Unit_Declaration_Node (Current_Scope))));
+                              (Specification
+                                 (Unit_Declaration_Node (Current_Scope))));
 
                   while Present (Decl) loop
                      if Nkind (Decl) = N_Private_Type_Declaration
@@ -3566,7 +3572,7 @@ package body Sem_Ch13 is
                      then
                         Illegal_Indexing
                           ("Indexing aspect cannot be specified on full view "
-                             & "if partial view is tagged");
+                           & "if partial view is tagged");
                         return;
                      end if;
 
@@ -3678,9 +3684,7 @@ package body Sem_Ch13 is
             end;
          end if;
 
-         if not Indexing_Found
-           and then not Error_Posted (N)
-         then
+         if not Indexing_Found and then not Error_Posted (N) then
             Error_Msg_NE
               ("aspect Indexing requires a local function that "
                & "applies to type&", Expr, Ent);
@@ -10618,6 +10622,8 @@ package body Sem_Ch13 is
       --  Returns true if all elements of the list are OK static choices
       --  as defined below for Is_Static_Choice. Used for case expression
       --  alternatives and for the right operand of a membership test.
+      --  An others_choice is static if the corresponding expression is static.
+      --  The staticness of the bounds is checked separately.
 
       function Is_Static_Choice (N : Node_Id) return Boolean;
       --  Returns True if N represents a static choice (static subtype, or
@@ -10683,7 +10689,8 @@ package body Sem_Ch13 is
 
       function Is_Static_Choice (N : Node_Id) return Boolean is
       begin
-         return Is_OK_Static_Expression (N)
+         return Nkind (N) = N_Others_Choice
+           or else Is_OK_Static_Expression (N)
            or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
                      and then Is_OK_Static_Subtype (Entity (N)))
            or else (Nkind (N) = N_Subtype_Indication

gcc/ada/sem_ch3.adb

@@ -4514,6 +4514,8 @@ package body Sem_Ch3 is
 
             when Enumeration_Kind =>
                Set_Ekind                (Id, E_Enumeration_Subtype);
+               Set_Has_Dynamic_Predicate_Aspect (Id,
+                                   Has_Dynamic_Predicate_Aspect (T));
                Set_First_Literal        (Id, First_Literal (Base_Type (T)));
                Set_Scalar_Range         (Id, Scalar_Range       (T));
                Set_Is_Character_Type    (Id, Is_Character_Type  (T));