[multiple changes]

2015-11-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_aggr.adb (Is_Completely_Hidden_Discriminant): New routine.
	(Init_Hidden_Discriminants): Code reformatting. Do not initialize
	a completely hidden discriminant.
	* a-interr.ads (Get_CPU): Added SPARK_Mode, Volatile_Function
	and Global aspects on the function.

2015-11-18  Ed Schonberg  <schonberg@adacore.com>

	* exp_intr.adb (Expand_Unc_Deallocation): If the designated
	type is a concurrent type, the deallocation applies to the
	corresponding record type, or to its class-wide type if the type
	is tagged.

From-SVN: r230535

4 files changed, 121 insertions, 38 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4f3dde0..54ec263 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2015-11-18  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_aggr.adb (Is_Completely_Hidden_Discriminant): New routine.
+	(Init_Hidden_Discriminants): Code reformatting. Do not initialize
+	a completely hidden discriminant.
+	* a-interr.ads (Get_CPU): Added SPARK_Mode, Volatile_Function
+	and Global aspects on the function.
+
+2015-11-18  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_intr.adb (Expand_Unc_Deallocation): If the designated
+	type is a concurrent type, the deallocation applies to the
+	corresponding record type, or to its class-wide type if the type
+	is tagged.
+
 2015-11-18  Doug Rupp  <rupp@adacore.com>
 
 	* s-parame-vxworks.adb: Reduce default stack size for stack
diff --git a/gcc/ada/a-interr.ads b/gcc/ada/a-interr.ads
index 309e88e..562f278 100644
--- a/gcc/ada/a-interr.ads
+++ b/gcc/ada/a-interr.ads
@@ -83,7 +83,11 @@ package Ada.Interrupts is
      Global     => null;
 
    function Get_CPU
-     (Interrupt : Interrupt_ID) return System.Multiprocessors.CPU_Range;
+     (Interrupt : Interrupt_ID) return System.Multiprocessors.CPU_Range
+   with
+     SPARK_Mode,
+     Volatile_Function,
+     Global => Ada.Task_Identification.Tasking_State;
 
 private
    pragma Inline (Is_Reserved);
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index ad23a66..002579b 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -2124,11 +2124,51 @@ package body Exp_Aggr is
       -------------------------------
 
       procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is
-         Btype        : Entity_Id;
-         Parent_Type  : Entity_Id;
-         Disc         : Entity_Id;
-         Discr_Val    : Elmt_Id;
+         function Is_Completely_Hidden_Discriminant
+           (Discr : Entity_Id) return Boolean;
+         --  Determine whether Discr is a completely hidden discriminant of
+         --  type Typ.
+
+         ---------------------------------------
+         -- Is_Completely_Hidden_Discriminant --
+         ---------------------------------------
+
+         function Is_Completely_Hidden_Discriminant
+           (Discr : Entity_Id) return Boolean
+         is
+            Item : Entity_Id;
+
+         begin
+            --  Use First/Next_Entity as First/Next_Discriminant do not yield
+            --  completely hidden discriminants.
+
+            Item := First_Entity (Typ);
+            while Present (Item) loop
+               if Ekind (Item) = E_Discriminant
+                 and then Is_Completely_Hidden (Item)
+                 and then Chars (Original_Record_Component (Item)) =
+                          Chars (Discr)
+               then
+                  return True;
+               end if;
+
+               Next_Entity (Item);
+            end loop;
+
+            return False;
+         end Is_Completely_Hidden_Discriminant;
+
+         --  Local variables
+
+         Base_Typ     : Entity_Id;
+         Discr        : Entity_Id;
+         Discr_Constr : Elmt_Id;
+         Discr_Init   : Node_Id;
+         Discr_Val    : Node_Id;
          In_Aggr_Type : Boolean;
+         Par_Typ      : Entity_Id;
+
+      --  Start of processing for Init_Hidden_Discriminants
 
       begin
          --  The constraints on the hidden discriminants, if present, are kept
@@ -2139,67 +2179,84 @@ package body Exp_Aggr is
 
          In_Aggr_Type := True;
 
-         Btype := Base_Type (Typ);
-         while Is_Derived_Type (Btype)
+         Base_Typ := Base_Type (Typ);
+         while Is_Derived_Type (Base_Typ)
            and then
-             (Present (Stored_Constraint (Btype))
+             (Present (Stored_Constraint (Base_Typ))
                or else
                  (In_Aggr_Type and then Present (Stored_Constraint (Typ))))
          loop
-            Parent_Type := Etype (Btype);
+            Par_Typ := Etype (Base_Typ);
 
-            if not Has_Discriminants (Parent_Type) then
+            if not Has_Discriminants (Par_Typ) then
                return;
             end if;
 
-            Disc := First_Discriminant (Parent_Type);
+            Discr := First_Discriminant (Par_Typ);
 
             --  We know that one of the stored-constraint lists is present
 
-            if Present (Stored_Constraint (Btype)) then
-               Discr_Val := First_Elmt (Stored_Constraint (Btype));
+            if Present (Stored_Constraint (Base_Typ)) then
+               Discr_Constr := First_Elmt (Stored_Constraint (Base_Typ));
 
             --  For private extension, stored constraint may be on full view
 
-            elsif Is_Private_Type (Btype)
-              and then Present (Full_View (Btype))
-              and then Present (Stored_Constraint (Full_View (Btype)))
+            elsif Is_Private_Type (Base_Typ)
+              and then Present (Full_View (Base_Typ))
+              and then Present (Stored_Constraint (Full_View (Base_Typ)))
             then
-               Discr_Val := First_Elmt (Stored_Constraint (Full_View (Btype)));
+               Discr_Constr :=
+                 First_Elmt (Stored_Constraint (Full_View (Base_Typ)));
 
             else
-               Discr_Val := First_Elmt (Stored_Constraint (Typ));
+               Discr_Constr := First_Elmt (Stored_Constraint (Typ));
             end if;
 
-            while Present (Discr_Val) and then Present (Disc) loop
+            while Present (Discr) and then Present (Discr_Constr) loop
+               Discr_Val := Node (Discr_Constr);
 
-               --  Only those discriminants of the parent that are not
-               --  renamed by discriminants of the derived type need to
-               --  be added explicitly.
+               --  The parent discriminant is renamed in the derived type,
+               --  nothing to initialize.
 
-               if not Is_Entity_Name (Node (Discr_Val))
-                 or else Ekind (Entity (Node (Discr_Val))) /= E_Discriminant
+               --    type Deriv_Typ (Discr : ...)
+               --      is new Parent_Typ (Discr => Discr);
+
+               if Is_Entity_Name (Discr_Val)
+                 and then Ekind (Entity (Discr_Val)) = E_Discriminant
                then
-                  Comp_Expr :=
-                    Make_Selected_Component (Loc,
-                      Prefix        => New_Copy_Tree (Target),
-                      Selector_Name => New_Occurrence_Of (Disc, Loc));
+                  null;
 
-                  Instr :=
+               --  When the parent discriminant is constrained at the type
+               --  extension level, it does not appear in the derived type.
+
+               --    type Deriv_Typ (Discr : ...)
+               --      is new Parent_Typ (Discr        => Discr,
+               --                         Hidden_Discr => Expression);
+
+               elsif Is_Completely_Hidden_Discriminant (Discr) then
+                  null;
+
+               --  Otherwise initialize the discriminant
+
+               else
+                  Discr_Init :=
                     Make_OK_Assignment_Statement (Loc,
-                      Name       => Comp_Expr,
-                      Expression => New_Copy_Tree (Node (Discr_Val)));
+                      Name       =>
+                        Make_Selected_Component (Loc,
+                          Prefix        => New_Copy_Tree (Target),
+                          Selector_Name => New_Occurrence_Of (Discr, Loc)),
+                      Expression => New_Copy_Tree (Discr_Val));
 
-                  Set_No_Ctrl_Actions (Instr);
-                  Append_To (List, Instr);
+                  Set_No_Ctrl_Actions (Discr_Init);
+                  Append_To (List, Discr_Init);
                end if;
 
-               Next_Discriminant (Disc);
-               Next_Elmt (Discr_Val);
+               Next_Elmt (Discr_Constr);
+               Next_Discriminant (Discr);
             end loop;
 
             In_Aggr_Type := False;
-            Btype := Base_Type (Parent_Type);
+            Base_Typ := Base_Type (Par_Typ);
          end loop;
       end Init_Hidden_Discriminants;
 
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index ab30c1f..beaa24a 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -1071,10 +1071,17 @@ package body Exp_Intr is
 
          --  If the designated type is tagged, the finalization call must
          --  dispatch because the designated type may not be the actual type
-         --  of the object.
+         --  of the object. If the type is synchronized, the deallocation
+         --  applies to the corresponding record type.
 
          if Is_Tagged_Type (Desig_Typ) then
-            if not Is_Class_Wide_Type (Desig_Typ) then
+            if Is_Concurrent_Type (Desig_Typ) then
+               Obj_Ref :=
+                 Unchecked_Convert_To
+                   (Class_Wide_Type (Corresponding_Record_Type (Desig_Typ)),
+                      Obj_Ref);
+
+            elsif not Is_Class_Wide_Type (Desig_Typ) then
                Obj_Ref :=
                  Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref);
             end if;