[multiple changes]

2014-10-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Add_Invariants): For a class-wide type invariant,
	preserve semantic information on the invariant expression
	(typically a function call) because it may be inherited by a
	type extension in a different unit, and it cannot be resolved
	by visibility elsewhere because it may refer to local entities.

2014-10-17  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Document that string literal can be used for
	pragma Warnings when operating in Ada 83 mode.

2014-10-17  Ed Schonberg  <schonberg@adacore.com>

	* freeze.adb (Find_Aggregate_Component_Desig_Type): New
	subsidiary function to Freeze_ Expression, used to determine
	whether an aggregate for an array of access types also freezes the
	designated type, when some aggregate components are allocators.

2014-10-17  Ed Schonberg  <schonberg@adacore.com>

	* a-strsea.adb (Find_Token): AI05-031 indicates that the
	procedure must raise Index_Error when Source is not empty and
	the From parameter is not within the range of the Source string.

2014-10-17  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Is_Static_String_Expression): Allow string
	literal in Ada 83 mode.

From-SVN: r216377

gcc/ada/ChangeLog

+2014-10-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch13.adb (Add_Invariants): For a class-wide type invariant,
+	preserve semantic information on the invariant expression
+	(typically a function call) because it may be inherited by a
+	type extension in a different unit, and it cannot be resolved
+	by visibility elsewhere because it may refer to local entities.
+
+2014-10-17  Robert Dewar  <dewar@adacore.com>
+
+	* gnat_rm.texi: Document that string literal can be used for
+	pragma Warnings when operating in Ada 83 mode.
+
+2014-10-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* freeze.adb (Find_Aggregate_Component_Desig_Type): New
+	subsidiary function to Freeze_ Expression, used to determine
+	whether an aggregate for an array of access types also freezes the
+	designated type, when some aggregate components are allocators.
+
+2014-10-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-strsea.adb (Find_Token): AI05-031 indicates that the
+	procedure must raise Index_Error when Source is not empty and
+	the From parameter is not within the range of the Source string.
+
+2014-10-17  Robert Dewar  <dewar@adacore.com>
+
+	* sem_prag.adb (Is_Static_String_Expression): Allow string
+	literal in Ada 83 mode.
+
 2014-10-17  Vincent Celier  <celier@adacore.com>
 
 	* prj-conf.adb (Get_Config_Switches): In CodePeer mode, do

gcc/ada/a-strsea.adb

@@ -203,6 +203,12 @@ package body Ada.Strings.Search is
       Last   : out Natural)
    is
    begin
+      --  AI05-031: Raise Index error if Source non-empty and From not in range
+
+      if Source'Length /= 0 and then From not in Source'Range then
+         raise Index_Error;
+      end if;
+
       for J in From .. Source'Last loop
          if Belongs (Source (J), Set, Test) then
             First := J;

gcc/ada/freeze.adb

@@ -5958,12 +5958,52 @@ package body Freeze is
       --  may reference entities that have to be frozen before the body and
       --  obviously cannot be frozen inside the body.
 
+      function Find_Aggregate_Component_Desig_Type return Entity_Id;
+      --  If the expression is an array aggregate, the type of the component
+      --  expressions is also frozen. If the component type is an access type
+      --  and the expressions include allocators, the designed type is frozen
+      --  as well.
+
       function In_Exp_Body (N : Node_Id) return Boolean;
       --  Given an N_Handled_Sequence_Of_Statements node N, determines whether
       --  it is the handled statement sequence of an expander-generated
       --  subprogram (init proc, stream subprogram, or renaming as body).
       --  If so, this is not a freezing context.
 
+      -----------------------------------------
+      -- Find_Aggregate_Component_Desig_Type --
+      -----------------------------------------
+
+      function Find_Aggregate_Component_Desig_Type return Entity_Id is
+         Assoc : Node_Id;
+         Exp   : Node_Id;
+
+      begin
+         if Present (Expressions (N)) then
+            Exp := First (Expressions (N));
+            while Present (Exp) loop
+               if Nkind (Exp) = N_Allocator then
+                  return Designated_Type (Component_Type (Etype (N)));
+               end if;
+
+               Next (Exp);
+            end loop;
+         end if;
+
+         if Present (Component_Associations (N)) then
+            Assoc := First  (Component_Associations (N));
+            while Present (Assoc) loop
+               if Nkind (Expression (Assoc)) = N_Allocator then
+                  return Designated_Type (Component_Type (Etype (N)));
+               end if;
+
+               Next (Assoc);
+            end loop;
+         end if;
+
+         return Empty;
+      end Find_Aggregate_Component_Desig_Type;
+
       -----------------
       -- In_Exp_Body --
       -----------------
@@ -6104,7 +6144,10 @@ package body Freeze is
             if Is_Array_Type (Etype (N))
               and then Is_Access_Type (Component_Type (Etype (N)))
             then
-               Desig_Typ := Designated_Type (Component_Type (Etype (N)));
+
+               --  Check whether aggregate includes allocators.
+
+               Desig_Typ := Find_Aggregate_Component_Desig_Type;
             end if;
 
          when N_Selected_Component |

gcc/ada/gnat_rm.texi

@@ -7829,6 +7829,9 @@ pragma Warnings (static_string_EXPRESSION [,REASON]);
 pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
 
 REASON ::= Reason => STRING_LITERAL @{& STRING_LITERAL@}
+
+Note: in Ada 83 mode, a string literal may be used in place of
+a static string expression (which does not exist in Ada 83).
 @end smallexample
 
 @noindent

gcc/ada/sem_ch13.adb

@@ -2947,8 +2947,7 @@ package body Sem_Ch13 is
                         --  evaluation of this aspect should be delayed to the
                         --  freeze point (why???)
 
-                        if No (Expr)
-                          or else Is_True (Static_Boolean (Expr))
+                        if No (Expr) or else Is_True (Static_Boolean (Expr))
                         then
                            Set_Uses_Lock_Free (E);
                         end if;
@@ -3621,10 +3620,10 @@ package body Sem_Ch13 is
                if (Attr = Name_Constant_Indexing
                     and then Present
                       (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing)))
-
-                 or else (Attr = Name_Variable_Indexing
-                    and then Present
-                      (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
+                 or else
+                   (Attr = Name_Variable_Indexing
+                     and then Present
+                       (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
                then
                   if Debug_Flag_Dot_XX then
                      null;
@@ -4269,11 +4268,7 @@ package body Sem_Ch13 is
 
             --  Case of address clause for a (non-controlled) object
 
-            elsif
-              Ekind (U_Ent) = E_Variable
-                or else
-              Ekind (U_Ent) = E_Constant
-            then
+            elsif Ekind_In (U_Ent, E_Variable, E_Constant) then
                declare
                   Expr  : constant Node_Id := Expression (N);
                   O_Ent : Entity_Id;
@@ -4295,7 +4290,7 @@ package body Sem_Ch13 is
 
                   if Present (O_Ent)
                     and then (Has_Controlled_Component (Etype (O_Ent))
-                                or else Is_Controlled (Etype (O_Ent)))
+                               or else Is_Controlled (Etype (O_Ent)))
                   then
                      Error_Msg_N
                        ("??cannot overlay with controlled object", Expr);
@@ -4826,13 +4821,10 @@ package body Sem_Ch13 is
             --  except from aspect specification.
 
             if From_Aspect_Specification (N) then
-               if not (Is_Protected_Type (U_Ent)
-                        or else Is_Task_Type (U_Ent))
-               then
+               if not Is_Concurrent_Type (U_Ent) then
                   Error_Msg_N
-                    ("Interrupt_Priority can only be defined for task" &
-                     "and protected object",
-                     Nam);
+                    ("Interrupt_Priority can only be defined for task "
+                     & "and protected object", Nam);
 
                elsif Duplicate_Clause then
                   null;
@@ -4985,14 +4977,12 @@ package body Sem_Ch13 is
             --  aspect specification.
 
             if From_Aspect_Specification (N) then
-               if not (Is_Protected_Type (U_Ent)
-                        or else Is_Task_Type (U_Ent)
+               if not (Is_Concurrent_Type (U_Ent)
                         or else Ekind (U_Ent) = E_Procedure)
                then
                   Error_Msg_N
-                    ("Priority can only be defined for task and protected " &
-                     "object",
-                     Nam);
+                    ("Priority can only be defined for task and protected "
+                     & "object", Nam);
 
                elsif Duplicate_Clause then
                   null;
@@ -5828,6 +5818,7 @@ package body Sem_Ch13 is
 
             if Val = No_Uint then
                Err := True;
+
             elsif Val < Lo or else Hi < Val then
                Error_Msg_N ("value outside permitted range", Expr);
                Err := True;
@@ -7625,6 +7616,29 @@ package body Sem_Ch13 is
                Set_Parent (Exp, N);
                Preanalyze_Assert_Expression (Exp, Standard_Boolean);
 
+               --  A class-wide invariant may be inherited in a separate unit,
+               --  where the corresponding expression cannot be resolved by
+               --  visibility, because it refers to a local function. Propagate
+               --  semantic information to the original representation item, to
+               --  be used when an invariant procedure for a derived type is
+               --  constructed.
+
+               --  Unclear how to handle class-wide invariants that are not
+               --  function calls ???
+
+               if not Inherit
+                 and then Class_Present (Ritem)
+                 and then Nkind (Exp) = N_Function_Call
+                 and then Nkind (Arg2) = N_Indexed_Component
+               then
+                  Rewrite (Arg2,
+                    Make_Function_Call (Loc,
+                      Name                   =>
+                        New_Occurrence_Of (Entity (Name (Exp)), Loc),
+                      Parameter_Associations =>
+                        New_Copy_List (Expressions (Arg2))));
+               end if;
+
                --  In ASIS mode, even if assertions are not enabled, we must
                --  analyze the original expression in the aspect specification
                --  because it is part of the original tree.
@@ -8501,9 +8515,9 @@ package body Sem_Ch13 is
       --  at the freeze point.
 
       elsif A_Id = Aspect_Input  or else
-         A_Id = Aspect_Output    or else
-         A_Id = Aspect_Read      or else
-         A_Id = Aspect_Write
+            A_Id = Aspect_Output or else
+            A_Id = Aspect_Read   or else
+            A_Id = Aspect_Write
       then
          Analyze (End_Decl_Expr);
          Check_Overloaded_Name;
@@ -8862,8 +8876,8 @@ package body Sem_Ch13 is
                     and then Has_Discriminants (T))
                  or else
                   (Is_Access_Type (T)
-                     and then Is_Record_Type (Designated_Type (T))
-                     and then Has_Discriminants (Designated_Type (T)))
+                    and then Is_Record_Type (Designated_Type (T))
+                    and then Has_Discriminants (Designated_Type (T)))
                then
                   Error_Msg_NE
                     ("invalid address clause for initialized object &!",
@@ -8954,11 +8968,8 @@ package body Sem_Ch13 is
                then
                   return;
 
-               elsif
-                  Ekind (Ent) = E_Constant
-                    or else
-                  Ekind (Ent) = E_In_Parameter
-               then
+               elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then
+
                   --  This is the case where we must have Ent defined before
                   --  U_Ent. Clearly if they are in different units this
                   --  requirement is met since the unit containing Ent is
@@ -11132,9 +11143,7 @@ package body Sem_Ch13 is
       --  need to know such a size, but this routine may be called with a
       --  generic type as part of normal processing.
 
-      elsif Is_Generic_Type (R_Typ)
-        or else R_Typ = Any_Type
-      then
+      elsif Is_Generic_Type (R_Typ) or else R_Typ = Any_Type then
          return 0;
 
          --  Access types (cannot have size smaller than System.Address)
@@ -11849,8 +11858,7 @@ package body Sem_Ch13 is
          (Is_Record_Type (T2) or else Is_Array_Type (T2))
         and then
          (Component_Alignment (T1) /= Component_Alignment (T2)
-            or else
-              Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
+           or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
       then
          return False;
       end if;
@@ -12739,9 +12747,7 @@ package body Sem_Ch13 is
 
          Prim := First (Choices (Assoc));
 
-         if Nkind (Prim) /= N_Identifier
-           or else Present (Next (Prim))
-         then
+         if Nkind (Prim) /= N_Identifier or else Present (Next (Prim)) then
             Error_Msg_N ("illegal name in association", Prim);
 
          elsif Chars (Prim) = Name_First then
@@ -12858,24 +12864,22 @@ package body Sem_Ch13 is
       if Warn_On_Unchecked_Conversion
         and then not In_Predefined_Unit (N)
         and then RTU_Loaded (Ada_Calendar)
-        and then
-          (Chars (Source) = Name_Time
-             or else
-           Chars (Target) = Name_Time)
+        and then (Chars (Source) = Name_Time
+                    or else
+                  Chars (Target) = Name_Time)
       then
          --  If Ada.Calendar is loaded and the name of one of the operands is
          --  Time, there is a good chance that this is Ada.Calendar.Time.
 
          declare
-            Calendar_Time : constant Entity_Id :=
-                              Full_View (RTE (RO_CA_Time));
+            Calendar_Time : constant Entity_Id := Full_View (RTE (RO_CA_Time));
          begin
             pragma Assert (Present (Calendar_Time));
 
             if Source = Calendar_Time or else Target = Calendar_Time then
                Error_Msg_N
-                 ("?z?representation of 'Time values may change between " &
-                  "'G'N'A'T versions", N);
+                 ("?z?representation of 'Time values may change between "
+                  & "'G'N'A'T versions", N);
             end if;
          end;
       end if;

gcc/ada/sem_prag.adb

@@ -3201,6 +3201,8 @@ package body Sem_Prag is
       function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
       --  Analyzes the argument, and determines if it is a static string
       --  expression, returns True if so, False if non-static or not String.
+      --  A special case is that a string literal returns True in Ada 83 mode
+      --  (which has no such thing as static string expressions).
 
       procedure Pragma_Misplaced;
       pragma No_Return (Pragma_Misplaced);
@@ -6220,11 +6222,25 @@ package body Sem_Prag is
 
       function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+         Lit  : constant Boolean := Nkind (Argx) = N_String_Literal;
 
       begin
          Analyze_And_Resolve (Argx);
-         return Is_OK_Static_Expression (Argx)
-           and then Nkind (Argx) = N_String_Literal;
+
+         --  Special case Ada 83, where the expression will never be static,
+         --  but we will return true if we had a string literal to start with.
+
+         if Ada_Version = Ada_83 then
+            return Lit;
+
+         --  Normal case, true only if we end up with a string literal that
+         --  is marked as being the result of evaluating a static expression.
+
+         else
+            return Is_OK_Static_Expression (Argx)
+              and then Nkind (Argx) = N_String_Literal;
+         end if;
+
       end Is_Static_String_Expression;
 
       ----------------------