[multiple changes]

2014-08-01  Robert Dewar  <dewar@adacore.com>

	* sem_ch7.adb, einfo.adb, einfo.ads, sem_ch13.adb: Minor change of
	identifier name.

2014-08-01  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb (Analyze_Object_Contract): Enable the volatility
	checks when the related variable comes from source.
	* sem_res.adb (Resolve_Actuals): Enable the volatility checks
	when the related actual parameter comes from source. Update comment.
	* freeze.adb (Freeze_Record_Type): Do not freeze the designated
	type of an array of pointers when the designated type is
	class-wide and its root type is the record being currently frozen.

2014-08-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb (Analyze_Iterator_Specification): Preserve Ekind
	of renaming declaration created for domain of iteration.
	* sem_aggr.adb (Resolve_Array_Aggregate): Better placement
	for error messages on aggregates whose index subtypes have
	predicates. The new placement avoids posting messages on previous
	subtype declarations rather than on the aggregate itself.
	* sem_disp.adb (Is_Inherited_Public_Operation): New predicate for
	Add_Dispatching_Operation, to handle properly the overriding of
	the predefined operations on controlled types, when the partial
	view of a type is not visibly controlled.

2014-08-01  Ben Brosgol  <brosgol@adacore.com>

	* gnat_ugn.texi: Add tutorial on portable fixed-point types as an
	appendix.

From-SVN: r213446

12 files changed, 322 insertions, 73 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 444d4f7..31bc891 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,36 @@
+2014-08-01  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch7.adb, einfo.adb, einfo.ads, sem_ch13.adb: Minor change of
+	identifier name.
+
+2014-08-01  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_ch3.adb (Analyze_Object_Contract): Enable the volatility
+	checks when the related variable comes from source.
+	* sem_res.adb (Resolve_Actuals): Enable the volatility checks
+	when the related actual parameter comes from source. Update comment.
+	* freeze.adb (Freeze_Record_Type): Do not freeze the designated
+	type of an array of pointers when the designated type is
+	class-wide and its root type is the record being currently frozen.
+
+2014-08-01  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch5.adb (Analyze_Iterator_Specification): Preserve Ekind
+	of renaming declaration created for domain of iteration.
+	* sem_aggr.adb (Resolve_Array_Aggregate): Better placement
+	for error messages on aggregates whose index subtypes have
+	predicates. The new placement avoids posting messages on previous
+	subtype declarations rather than on the aggregate itself.
+	* sem_disp.adb (Is_Inherited_Public_Operation): New predicate for
+	Add_Dispatching_Operation, to handle properly the overriding of
+	the predefined operations on controlled types, when the partial
+	view of a type is not visibly controlled.
+
+2014-08-01  Ben Brosgol  <brosgol@adacore.com>
+
+	* gnat_ugn.texi: Add tutorial on portable fixed-point types as an
+	appendix.
+
 2014-08-01  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* einfo.adb (Is_Hidden_Non_Overridden_Subprogram): Remove the
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 3b5219b..84e7763 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -269,8 +269,7 @@ package body Einfo is
    --  the spec of Einfo for further details.
 
    --    Is_Inlined_Always               Flag1
-   --    Is_Hidden_Non_Overridden_Subprogram
-   --                                    Flag2
+   --    Is_Hidden_Non_Overridden_Subpgm Flag2
    --    Is_Frozen                       Flag4
    --    Has_Discriminants               Flag5
    --    Is_Dispatching_Operation        Flag6
@@ -2066,10 +2065,10 @@ package body Einfo is
       return Flag57 (Id);
    end Is_Hidden;
 
-   function Is_Hidden_Non_Overridden_Subprogram (Id : E) return B is
+   function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B is
    begin
       return Flag2 (Id);
-   end Is_Hidden_Non_Overridden_Subprogram;
+   end Is_Hidden_Non_Overridden_Subpgm;
 
    function Is_Hidden_Open_Scope (Id : E) return B is
    begin
@@ -4847,10 +4846,11 @@ package body Einfo is
       Set_Flag57 (Id, V);
    end Set_Is_Hidden;
 
-   procedure Set_Is_Hidden_Non_Overridden_Subprogram (Id : E; V : B := True) is
+   procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True) is
    begin
+      pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
       Set_Flag2 (Id, V);
-   end Set_Is_Hidden_Non_Overridden_Subprogram;
+   end Set_Is_Hidden_Non_Overridden_Subpgm;
 
    procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True) is
    begin
@@ -8359,8 +8359,7 @@ package body Einfo is
       W ("Is_Generic_Instance",             Flag130 (Id));
       W ("Is_Generic_Type",                 Flag13  (Id));
       W ("Is_Hidden",                       Flag57  (Id));
-      W ("Is_Hidden_Non_Overridden_Subprogram",
-                                            Flag2   (Id));
+      W ("Is_Hidden_Non_Overridden_Subpgm", Flag2   (Id));
       W ("Is_Hidden_Open_Scope",            Flag171 (Id));
       W ("Is_Immediately_Visible",          Flag7   (Id));
       W ("Is_Implementation_Defined",       Flag254 (Id));
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 18de39f..27c8f30 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -2422,7 +2422,7 @@ package Einfo is
 --       child unit, and when compiling a private child unit (see Install_
 --       Private_Declaration in sem_ch7).
 
---    Is_Hidden_Non_Overridden_Subprogram (Flag2)
+--    Is_Hidden_Non_Overridden_Subpgm (Flag2)
 --       Defined in all entities. Set for implicitly declared subprograms
 --       that require overriding or are null procedures, and are hidden by
 --       a non-fully conformant homograph with the same characteristics
@@ -5663,7 +5663,7 @@ package Einfo is
    --    Is_Discriminant_Check_Function      (Flag264)
    --    Is_Eliminated                       (Flag124)
    --    Is_Generic_Actual_Subprogram        (Flag274)  (non-generic case only)
-   --    Is_Hidden_Non_Overridden_Subprogram (Flag2)    (non-generic case only)
+   --    Is_Hidden_Non_Overridden_Subpgm     (Flag2)    (non-generic case only)
    --    Is_Inlined_Always                   (Flag1)    (non-generic case only)
    --    Is_Instantiated                     (Flag126)  (generic case only)
    --    Is_Intrinsic_Subprogram             (Flag64)
@@ -5957,7 +5957,7 @@ package Einfo is
    --    Is_Constructor                      (Flag76)
    --    Is_Eliminated                       (Flag124)
    --    Is_Generic_Actual_Subprogram        (Flag274)  (non-generic case only)
-   --    Is_Hidden_Non_Overridden_Subprogram (Flag2)    (non-generic case only)
+   --    Is_Hidden_Non_Overridden_Subpgm     (Flag2)    (non-generic case only)
    --    Is_Inlined_Always                   (Flag1)    (non-generic case only)
    --    Is_Instantiated                     (Flag126)  (generic case only)
    --    Is_Interrupt_Handler                (Flag89)
@@ -6670,7 +6670,7 @@ package Einfo is
    function Is_Frozen                           (Id : E) return B;
    function Is_Generic_Instance                 (Id : E) return B;
    function Is_Hidden                           (Id : E) return B;
-   function Is_Hidden_Non_Overridden_Subprogram (Id : E) return B;
+   function Is_Hidden_Non_Overridden_Subpgm     (Id : E) return B;
    function Is_Hidden_Open_Scope                (Id : E) return B;
    function Is_Immediately_Visible              (Id : E) return B;
    function Is_Implementation_Defined           (Id : E) return B;
@@ -7307,8 +7307,7 @@ package Einfo is
    procedure Set_Is_Generic_Instance             (Id : E; V : B := True);
    procedure Set_Is_Generic_Type                 (Id : E; V : B := True);
    procedure Set_Is_Hidden                       (Id : E; V : B := True);
-   procedure Set_Is_Hidden_Non_Overridden_Subprogram
-                                                 (Id : E; V : B := True);
+   procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True);
    procedure Set_Is_Hidden_Open_Scope            (Id : E; V : B := True);
    procedure Set_Is_Immediately_Visible          (Id : E; V : B := True);
    procedure Set_Is_Implementation_Defined       (Id : E; V : B := True);
@@ -8076,7 +8075,7 @@ package Einfo is
    pragma Inline (Is_Generic_Type);
    pragma Inline (Is_Generic_Unit);
    pragma Inline (Is_Hidden);
-   pragma Inline (Is_Hidden_Non_Overridden_Subprogram);
+   pragma Inline (Is_Hidden_Non_Overridden_Subpgm);
    pragma Inline (Is_Hidden_Open_Scope);
    pragma Inline (Is_Immediately_Visible);
    pragma Inline (Is_Implementation_Defined);
@@ -8533,7 +8532,7 @@ package Einfo is
    pragma Inline (Set_Is_Generic_Instance);
    pragma Inline (Set_Is_Generic_Type);
    pragma Inline (Set_Is_Hidden);
-   pragma Inline (Set_Is_Hidden_Non_Overridden_Subprogram);
+   pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm);
    pragma Inline (Set_Is_Hidden_Open_Scope);
    pragma Inline (Set_Is_Immediately_Visible);
    pragma Inline (Set_Is_Implementation_Defined);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index e499701..9332930 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -2667,10 +2667,10 @@ package body Freeze is
       ------------------------
 
       procedure Freeze_Record_Type (Rec : Entity_Id) is
+         ADC  : Node_Id;
          Comp : Entity_Id;
          IR   : Node_Id;
          Prev : Entity_Id;
-         ADC  : Node_Id;
 
          Junk : Boolean;
          pragma Warnings (Off, Junk);
@@ -3123,18 +3123,56 @@ package body Freeze is
             then
                Check_Itype (Etype (Comp));
 
+            --  Freeze the designated type when initializing a component with
+            --  an aggregate in case the aggregate contains allocators.
+
+            --     type T is ...;
+            --     type T_Ptr is access all T;
+            --     type T_Array is array ... of T_Ptr;
+
+            --     type Rec is record
+            --        Comp : T_Array := (others => ...);
+            --     end record;
+
             elsif Is_Array_Type (Etype (Comp))
               and then Is_Access_Type (Component_Type (Etype (Comp)))
-              and then Present (Parent (Comp))
-              and then Nkind (Parent (Comp)) = N_Component_Declaration
-              and then Present (Expression (Parent (Comp)))
-              and then Nkind (Expression (Parent (Comp))) = N_Aggregate
-              and then Is_Fully_Defined
-                         (Designated_Type (Component_Type (Etype (Comp))))
             then
-               Freeze_And_Append
-                 (Designated_Type
-                    (Component_Type (Etype (Comp))), N, Result);
+               declare
+                  Comp_Par  : constant Node_Id   := Parent (Comp);
+                  Desig_Typ : constant Entity_Id :=
+                                Designated_Type
+                                  (Component_Type (Etype (Comp)));
+
+               begin
+                  --  The only case when this sort of freezing is not done is
+                  --  when the designated type is class-wide and the root type
+                  --  is the record owning the component. This scenario results
+                  --  in a circularity because the class-wide type requires
+                  --  primitives that have not been created yet as the root
+                  --  type is in the process of being frozen.
+
+                  --     type Rec is tagged;
+                  --     type Rec_Ptr is access all Rec'Class;
+                  --     type Rec_Array is array ... of Rec_Ptr;
+
+                  --     type Rec is record
+                  --        Comp : Rec_Array := (others => ...);
+                  --     end record;
+
+                  if Is_Class_Wide_Type (Desig_Typ)
+                    and then Root_Type (Desig_Typ) = Rec
+                  then
+                     null;
+
+                  elsif Is_Fully_Defined (Desig_Typ)
+                    and then Present (Comp_Par)
+                    and then Nkind (Comp_Par) = N_Component_Declaration
+                    and then Present (Expression (Comp_Par))
+                    and then Nkind (Expression (Comp_Par)) = N_Aggregate
+                  then
+                     Freeze_And_Append (Desig_Typ, N, Result);
+                  end if;
+               end;
             end if;
 
             Prev := Comp;
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 83be002..a63aa76 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -190,6 +190,7 @@ AdaCore@*
 * Overflow Check Handling in GNAT::
 * Conditional Compilation::
 * Inline Assembler::
+* Writing Portable Fixed-Point Declarations::
 * Compatibility and Porting Guide::
 * Microsoft Windows Topics::
 * Mac OS Topics::
@@ -427,6 +428,10 @@ both with Ada in general and with GNAT facilities in particular.
 in an Ada program.
 
 @item
+@ref{Writing Portable Fixed-Point Declarations}, gives some guidance on
+defining portable fixed-point types.
+
+@item
 @ref{Compatibility and Porting Guide}, contains sections on compatibility
 of GNAT with other Ada development environments (including Ada 83 systems),
 to assist in porting code from those environments.
@@ -26410,6 +26415,146 @@ problems.
 @c END OF INLINE ASSEMBLER CHAPTER
 @c ===============================
 
+
+@c *****************************************
+@c Writing Portable Fixed-Point Declarations
+@c *****************************************
+@node Writing Portable Fixed-Point Declarations
+@appendix Writing Portable Fixed-Point Declarations
+@cindex Fixed-point types (writing portable declarations)
+
+@noindent
+The Ada Reference Manual gives an implementation freedom to choose bounds
+that are narrower by @code{Small} from the given bounds.
+For example, if we write
+
+@smallexample @c ada
+   type F1 is delta 1.0 range -128.0 .. +128.0;
+@end smallexample
+
+@noindent
+then the implementation is allowed to choose -128.0 .. +127.0 if it
+likes, but is not required to do so.
+
+This leads to possible portability problems, so let's have a closer
+look at this, and figure out how to avoid these problems.
+
+First, why does this freedom exist, and why would an implementation
+take advantage of it? To answer this, take a closer look at the type
+declaration for @code{F1} above. If the compiler uses the given bounds,
+it would need 9 bits to hold the largest positive value (and typically
+that means 16 bits on all machines). But if the implementation chooses
+the +127.0 bound then it can fit values of the type in 8 bits.
+
+Why not make the user write +127.0 if that's what is wanted?
+The rationale is that if you are thinking of fixed point
+as a kind of ``poor man's floating-point'', then you don't want
+to be thinking about the scaled integers that are used in its
+representation. Let's take another example:
+
+@smallexample @c ada
+   type F2 is delta 2.0**(-15) range -1.0 .. +1.0;
+@end smallexample
+
+@noindent
+Looking at this declaration, it seems casually as though
+it should fit in 16 bits, but again that extra positive value
++1.0 has the scaled integer equivalent of 2**15 which is one too
+big for signed 16 bits. The implementation can treat this as:
+
+@smallexample @c ada
+   type F2 is delta 2.0**(-15) range -1.0 .. +1.0-(2.0**(-15));
+@end smallexample
+
+@noindent
+and the Ada language design team felt that this was too annoying
+to require. We don't need to debate this decision at this point,
+since it is well established (the rule about narrowing the ranges
+dates to Ada 83).
+
+But the important point is that an implementation is not required
+to do this narrowing, so we have a potential portability problem.
+We could imagine three types of implementation:
+
+@enumerate a
+@item
+those that narrow the range automatically if they can figure
+out that the narrower range will allow storage in a smaller machine unit,
+
+@item
+those that will narrow only if forced to by a @code{'Size} clause, and
+
+@item
+those that will never narrow.
+@end enumerate
+
+@noindent
+Now if we are language theoreticians, we can imagine a fourth
+approach: is to narrow all the time, e.g. to treat
+
+@smallexample @c ada
+   type F3 is delta 1.0 range -10.0 .. +23.0;
+@end smallexample
+
+@noindent
+as though it had been written:
+
+@smallexample @c ada
+   type F3 is delta 1.0 range -9.0 .. +22.0;
+@end smallexample
+
+@noindent
+But although technically allowed, such a behavior would be hostile and silly,
+and no real compiler would do this. All real compilers will fall into one of
+the categories (a), (b) or (c) above.
+
+So, how do you get the compiler to do what you want? The answer is give the
+actual bounds you want, and then use a @code{'Small} clause and a
+@code{'Size} clause to absolutely pin down what the compiler does.
+E.g., for @code{F2} above, we will write:
+
+@smallexample @c ada
+@group
+   My_Small : constant := 2.0**(-15);
+   My_First : constant := -1.0;
+   My_Last  : constant := +1.0 - My_Small;
+
+   type F2 is delta My_Small range My_First .. My_Last;
+@end group
+@end smallexample
+
+@noindent
+and then add
+
+@smallexample @c ada
+@group
+   for F2'Small use my_Small;
+   for F2'Size  use 16;
+@end group
+@end smallexample
+
+@noindent
+In practice all compilers will do the same thing here and will give you
+what you want, so the above declarations are fully portable. If you really
+want to play language lawyer and guard against ludicrous behavior by the
+compiler you could add
+
+@smallexample @c ada
+@group
+   Test1 : constant := 1 / Boolean'Pos (F2'First = My_First);
+   Test2 : constant := 1 / Boolean'Pos (F2'Last  = My_Last);
+@end group
+@end smallexample
+
+@noindent
+One or other or both are allowed to be illegal if the compiler is
+behaving in a silly manner, but at least the silly compiler will not
+get away with silently messing with your (very clear) intentions.
+
+If you follow this scheme you will be guaranteed that your fixed-point
+types will be portable.
+
+
 @c ***********************************
 @c * Compatibility and Porting Guide *
 @c ***********************************
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index e5dfcaa..3ebaa7f 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -2230,30 +2230,37 @@ package body Sem_Aggr is
 
                            if Lo_Val > Hi_Val + 1 then
 
-                              --  Set location for flag, if the choice is an
-                              --  explicit Range, then point to the low bound,
-                              --  otherwise just point to  the choice.
+                              declare
+                                 Error_Node : Node_Id;
 
-                              Choice := Table (J).Choice;
+                              begin
+                                 --  If the choice is the bound of a range in
+                                 --  a subtype indication, it is not in the
+                                 --  source lists for the aggregate itself, so
+                                 --  post the error on the aggregate. Otherwise
+                                 --  post it on choice itself.
 
-                              if Nkind (Choice) = N_Range then
-                                 Choice := Low_Bound (Choice);
-                              end if;
+                                 Choice := Table (J).Choice;
 
-                              --  Now post appropriate message
+                                 if Is_List_Member (Choice) then
+                                    Error_Node := Choice;
+                                 else
+                                    Error_Node := N;
+                                 end if;
 
-                              if Hi_Val + 1 = Lo_Val - 1 then
-                                 Error_Msg_N
-                                   ("missing index value in array aggregate!",
-                                    Choice);
-                              else
-                                 Error_Msg_N
-                                   ("missing index values in array aggregate!",
-                                    Choice);
-                              end if;
+                                 if Hi_Val + 1 = Lo_Val - 1 then
+                                    Error_Msg_N
+                                      ("missing index value "
+                                       & "in array aggregate!", Error_Node);
+                                 else
+                                    Error_Msg_N
+                                      ("missing index values "
+                                       & "in array aggregate!", Error_Node);
+                                 end if;
 
-                              Output_Bad_Choices
-                                (Hi_Val + 1, Lo_Val - 1, Choice);
+                                 Output_Bad_Choices
+                                   (Hi_Val + 1, Lo_Val - 1, Error_Node);
+                              end;
                            end if;
                         end loop;
                      end if;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 06d5752..76c7a70 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -9981,13 +9981,13 @@ package body Sem_Ch13 is
                  and then Is_Non_Overridden_Or_Null_Procedure (Prim)
                  and then not Fully_Conformant (Prim, Subp_Id)
                then
-                  Set_Is_Hidden_Non_Overridden_Subprogram (Prim);
-                  Set_Is_Immediately_Visible              (Prim, False);
-                  Set_Is_Potentially_Use_Visible          (Prim, False);
+                  Set_Is_Hidden_Non_Overridden_Subpgm (Prim);
+                  Set_Is_Immediately_Visible          (Prim, False);
+                  Set_Is_Potentially_Use_Visible      (Prim, False);
 
-                  Set_Is_Hidden_Non_Overridden_Subprogram (Subp_Id);
-                  Set_Is_Immediately_Visible              (Subp_Id, False);
-                  Set_Is_Potentially_Use_Visible          (Subp_Id, False);
+                  Set_Is_Hidden_Non_Overridden_Subpgm (Subp_Id);
+                  Set_Is_Immediately_Visible          (Subp_Id, False);
+                  Set_Is_Potentially_Use_Visible      (Subp_Id, False);
                end if;
 
                Next_Elmt (Prim_Elmt);
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 53e0b47..e9f3061 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3037,9 +3037,10 @@ package body Sem_Ch3 is
       else pragma Assert (Ekind (Obj_Id) = E_Variable);
 
          --  The following checks are only relevant when SPARK_Mode is on as
-         --  they are not standard Ada legality rules.
+         --  they are not standard Ada legality rules. Internally generated
+         --  temporaries are ignored.
 
-         if SPARK_Mode = On then
+         if SPARK_Mode = On and then Comes_From_Source (Obj_Id) then
             if Is_Effectively_Volatile (Obj_Id) then
 
                --  The declaration of an effectively volatile object must
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 5013bcd..4bbd42f 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -1853,11 +1853,8 @@ package body Sem_Ch5 is
 
             --  The name in the renaming declaration may be a function call.
             --  Indicate that it does not come from source, to suppress
-            --  spurious warnings on renamings of parameterless functions, a
-            --  common enough idiom in user-defined iterators. The entity of
-            --  the renaming must be a variable, because user- defined Iterate
-            --  function may have in-out parameters, even if predefined ones do
-            --  not.
+            --  spurious warnings on renamings of parameterless functions,
+            --  a common enough idiom in user-defined iterators.
 
             Decl :=
               Make_Object_Renaming_Declaration (Loc,
@@ -1870,7 +1867,6 @@ package body Sem_Ch5 is
             Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
             Set_Etype (Id, Typ);
             Set_Etype (Name (N), Typ);
-            Set_Ekind (Id, E_Variable);
          end;
 
       --  Container is an entity or an array with uncontrolled components, or
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 5f110ec..f75b6c1 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -1986,7 +1986,7 @@ package body Sem_Ch7 is
          --  a tagged type back into visibility if they have non-conformant
          --  homographs (Ada RM 8.3 12.3/2).
 
-         elsif Is_Hidden_Non_Overridden_Subprogram (Id) then
+         elsif Is_Hidden_Non_Overridden_Subpgm (Id) then
             null;
 
          else
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index b764782..35f6181 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -86,6 +86,10 @@ package body Sem_Disp is
    --  This routine does not search for non-hidden primitives since they are
    --  covered by the normal Ada 2005 rules.
 
+   function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean;
+   --  Check whether a primitive operation is inherited from an operation
+   --  declared in the visible part of its package.
+
    -------------------------------
    -- Add_Dispatching_Operation --
    -------------------------------
@@ -1233,9 +1237,17 @@ package body Sem_Disp is
 
          Check_Subtype_Conformant (Subp, Ovr_Subp);
 
+         --  A primitive operation with the name of a primitive controlled
+         --  operation does not override a non-visible overriding controlled
+         --  operation, i.e. one declared in a private part when the full
+         --  view of a type is controlled. Conversely, it will override a
+         --  visible operation that may be declared in a partial view when
+         --  the full view is controlled.
+
          if Nam_In (Chars (Subp), Name_Initialize, Name_Adjust, Name_Finalize)
            and then Is_Controlled (Tagged_Type)
            and then not Is_Visibly_Controlled (Tagged_Type)
+           and then not Is_Inherited_Public_Operation (Ovr_Subp)
          then
             Set_Overridden_Operation (Subp, Empty);
 
@@ -2159,6 +2171,27 @@ package body Sem_Disp is
         and then Is_Interface (Find_Dispatching_Type (E));
    end Is_Null_Interface_Primitive;
 
+   -----------------------------------
+   -- Is_Inherited_Public_Operation --
+   -----------------------------------
+
+   function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean is
+      Prim      : constant Entity_Id := Alias (Op);
+      Scop      : constant Entity_Id := Scope (Prim);
+      Pack_Decl : Node_Id;
+
+   begin
+      if Comes_From_Source (Prim) and then Ekind (Scop) = E_Package then
+         Pack_Decl := Unit_Declaration_Node (Scop);
+         return Nkind (Pack_Decl) = N_Package_Declaration
+           and then List_Containing (Unit_Declaration_Node (Prim)) =
+                            Visible_Declarations (Specification (Pack_Decl));
+
+      else
+         return False;
+      end if;
+   end Is_Inherited_Public_Operation;
+
    --------------------------
    -- Is_Tag_Indeterminate --
    --------------------------
@@ -2222,8 +2255,7 @@ package body Sem_Disp is
       elsif Nkind (Orig_Node) = N_Attribute_Reference
         and then
           Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
-        and then
-          Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
+        and then Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
       then
          return True;
 
@@ -2267,9 +2299,7 @@ package body Sem_Disp is
       --  was malformed, and an error must have been emitted already.
 
       Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
-      while Present (Elmt)
-        and then Node (Elmt) /= Prev_Op
-      loop
+      while Present (Elmt) and then Node (Elmt) /= Prev_Op loop
          Next_Elmt (Elmt);
       end loop;
 
@@ -2304,9 +2334,8 @@ package body Sem_Disp is
          Replace_Elmt (Elmt, New_Op);
       end if;
 
-      if Ada_Version >= Ada_2005
-        and then Has_Interfaces (Tagged_Type)
-      then
+      if Ada_Version >= Ada_2005 and then Has_Interfaces (Tagged_Type) then
+
          --  Ada 2005 (AI-251): Update the attribute alias of all the aliased
          --  entities of the overridden primitive to reference New_Op, and
          --  also propagate the proper value of Is_Abstract_Subprogram. Verify
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 2d5766e..38c1017 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4325,10 +4325,12 @@ package body Sem_Res is
             end if;
 
             --  The following checks are only relevant when SPARK_Mode is on as
-            --  they are not standard Ada legality rule.
+            --  they are not standard Ada legality rule. Internally generated
+            --  temporaries are ignored.
 
             if SPARK_Mode = On
               and then Is_Effectively_Volatile_Object (A)
+              and then Comes_From_Source (A)
             then
                --  An effectively volatile object may act as an actual
                --  parameter when the corresponding formal is of a non-scalar
@@ -4353,9 +4355,9 @@ package body Sem_Res is
 
                --  Detect an external variable with an enabled property that
                --  does not match the mode of the corresponding formal in a
-               --  procedure call.
-
-               --  why only procedure calls ???
+               --  procedure call. Functions are not considered because they
+               --  cannot have effectively volatile formal parameters in the
+               --  first place.
 
                if Ekind (Nam) = E_Procedure
                  and then Is_Entity_Name (A)