[multiple changes]

2014-11-20  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb: Minor reformatting.

2014-11-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_util.adb (Make_Subtype_From_Expr): Capture the bounds of
	all index constracts when the expression is of an array type.

2014-11-20  Bob Duff  <duff@adacore.com>

	* s-taskin.ads: Minor comment improvements.

2014-11-20  Bob Duff  <duff@adacore.com>

	* exp_ch9.adb: Minor comment fixes.
	* s-taskin.adb (Initialize): Small simplification: pass System_Domain
	to Initialize_ATCB instead of passing null and then setting the Domain
	to System_Domain. This requires moving the creation of System_Domain
	earlier.
	* s-taprop-linux.adb (Set_Task_Affinity): Only call CPU_SET for
	processors that have a True in the Domain. This is necessary if the
	Domain is not all-True values.

2014-11-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Has_Good_Profile): a) An stream attribute
	for the class-wide type of an interface type is not a primitive
	operation and is not subject to the restrictions of 13.13. (38/3).
	b) A stream operation for an interface type must be a null
	procedure, and it cannot be a function.

From-SVN: r217857

8 files changed, 147 insertions, 45 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5fcfdc4..ce9c839 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,35 @@
+2014-11-20  Robert Dewar  <dewar@adacore.com>
+
+	* exp_attr.adb: Minor reformatting.
+
+2014-11-20  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_util.adb (Make_Subtype_From_Expr): Capture the bounds of
+	all index constracts when the expression is of an array type.
+
+2014-11-20  Bob Duff  <duff@adacore.com>
+
+	* s-taskin.ads: Minor comment improvements.
+
+2014-11-20  Bob Duff  <duff@adacore.com>
+
+	* exp_ch9.adb: Minor comment fixes.
+	* s-taskin.adb (Initialize): Small simplification: pass System_Domain
+	to Initialize_ATCB instead of passing null and then setting the Domain
+	to System_Domain. This requires moving the creation of System_Domain
+	earlier.
+	* s-taprop-linux.adb (Set_Task_Affinity): Only call CPU_SET for
+	processors that have a True in the Domain. This is necessary if the
+	Domain is not all-True values.
+
+2014-11-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch13.adb (Has_Good_Profile): a) An stream attribute
+	for the class-wide type of an interface type is not a primitive
+	operation and is not subject to the restrictions of 13.13. (38/3).
+	b) A stream operation for an interface type must be a null
+	procedure, and it cannot be a function.
+
 2014-11-20  Bob Duff  <duff@adacore.com>
 
 	* exp_attr.adb (Attribute_Max_Size_In_Storage_Elements):
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 595c548..663507a 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -4232,10 +4232,12 @@ package body Exp_Attr is
          --  retrieve the original attribute reference from the expression.
 
          Attr := N;
+
          if Nkind (Attr) = N_Type_Conversion then
             Attr := Expression (Attr);
             Conversion_Added := True;
          end if;
+
          pragma Assert (Nkind (Attr) = N_Attribute_Reference);
 
          --  Heap-allocated controlled objects contain two extra pointers which
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 9682859..4674da7 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -14146,9 +14146,7 @@ package body Exp_Ch9 is
          --  present, then the dispatching domain is null. If a rep item is
          --  present, then the dispatching domain is taken from the
          --  _Dispatching_Domain field of the task value record, which was set
-         --  from the rep item value. Note that this parameter must not be
-         --  generated for the restricted profiles since Ravenscar does not
-         --  allow dispatching domains.
+         --  from the rep item value.
 
          --  Case where Dispatching_Domain rep item applies: use given value
 
@@ -14162,7 +14160,7 @@ package body Exp_Ch9 is
                 Selector_Name =>
                   Make_Identifier (Loc, Name_uDispatching_Domain)));
 
-         --  No pragma or aspect Dispatching_Domain apply to the task
+         --  No pragma or aspect Dispatching_Domain applies to the task
 
          else
             Append_To (Args, Make_Null (Loc));
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index c855936..a833a0f 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6399,22 +6399,24 @@ package body Exp_Util is
      (E       : Node_Id;
       Unc_Typ : Entity_Id) return Node_Id
    is
-      Loc         : constant Source_Ptr := Sloc (E);
       List_Constr : constant List_Id    := New_List;
+      Loc         : constant Source_Ptr := Sloc (E);
       D           : Entity_Id;
-
-      Full_Subtyp  : Entity_Id;
-      Priv_Subtyp  : Entity_Id;
-      Utyp         : Entity_Id;
-      Full_Exp     : Node_Id;
+      Full_Exp    : Node_Id;
+      Full_Subtyp : Entity_Id;
+      High_Bound  : Entity_Id;
+      Index_Typ   : Entity_Id;
+      Low_Bound   : Entity_Id;
+      Priv_Subtyp : Entity_Id;
+      Utyp        : Entity_Id;
 
    begin
       if Is_Private_Type (Unc_Typ)
         and then Has_Unknown_Discriminants (Unc_Typ)
       then
-         --  Prepare the subtype completion, Go to base type to
-         --  find underlying type, because the type may be a generic
-         --  actual or an explicit subtype.
+         --  Prepare the subtype completion. Use the base type to find the
+         --  underlying type because the type may be a generic actual or an
+         --  explicit subtype.
 
          Utyp        := Underlying_Type (Base_Type (Unc_Typ));
          Full_Subtyp := Make_Temporary (Loc, 'C');
@@ -6451,22 +6453,67 @@ package body Exp_Util is
          return New_Occurrence_Of (Priv_Subtyp, Loc);
 
       elsif Is_Array_Type (Unc_Typ) then
+         Index_Typ := First_Index (Unc_Typ);
          for J in 1 .. Number_Dimensions (Unc_Typ) loop
-            Append_To (List_Constr,
-              Make_Range (Loc,
-                Low_Bound =>
+
+            --  Capture the bounds of each index constraint in case the context
+            --  is an object declaration of an unconstrained type initialized
+            --  by a function call:
+
+            --    Obj : Unconstr_Typ := Func_Call;
+
+            --  This scenario requires secondary scope management and the index
+            --  constraint cannot depend on the temporary used to capture the
+            --  result of the function call.
+
+            --    SS_Mark;
+            --    Temp : Unconstr_Typ_Ptr := Func_Call'reference;
+            --    subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
+            --    Obj : S := Temp.all;
+            --    SS_Release;  --  Temp is gone at this point, bounds of S are
+            --                 --  non existent.
+
+            --  The bounds are kept as variables rather than constants because
+            --  this prevents spurious optimizations down the line.
+
+            --  Generate:
+            --    Low_Bound : Base_Type (Index_Typ) := E'First (J);
+
+            Low_Bound := Make_Temporary (Loc, 'B');
+            Insert_Action (E,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => Low_Bound,
+                Object_Definition   =>
+                  New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
+                Expression          =>
                   Make_Attribute_Reference (Loc,
-                    Prefix => Duplicate_Subexpr_No_Checks (E),
+                    Prefix         => Duplicate_Subexpr_No_Checks (E),
                     Attribute_Name => Name_First,
-                    Expressions => New_List (
-                      Make_Integer_Literal (Loc, J))),
+                    Expressions    => New_List (
+                      Make_Integer_Literal (Loc, J)))));
+
+            --  Generate:
+            --    High_Bound : Base_Type (Index_Typ) := E'Last (J);
 
-                High_Bound =>
+            High_Bound := Make_Temporary (Loc, 'B');
+            Insert_Action (E,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => High_Bound,
+                Object_Definition   =>
+                  New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
+                Expression          =>
                   Make_Attribute_Reference (Loc,
                     Prefix         => Duplicate_Subexpr_No_Checks (E),
                     Attribute_Name => Name_Last,
                     Expressions    => New_List (
                       Make_Integer_Literal (Loc, J)))));
+
+            Append_To (List_Constr,
+              Make_Range (Loc,
+                Low_Bound  => New_Occurrence_Of (Low_Bound,  Loc),
+                High_Bound => New_Occurrence_Of (High_Bound, Loc)));
+
+            Index_Typ := Next_Index (Index_Typ);
          end loop;
 
       elsif Is_Class_Wide_Type (Unc_Typ) then
diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb
index ba5c212..a95013f 100644
--- a/gcc/ada/s-taprop-linux.adb
+++ b/gcc/ada/s-taprop-linux.adb
@@ -1516,7 +1516,9 @@ package body System.Task_Primitives.Operations is
                System.OS_Interface.CPU_ZERO (Size, CPU_Set);
 
                for Proc in T.Common.Domain'Range loop
-                  System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
+                  if T.Common.Domain (Proc) then
+                     System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
+                  end if;
                end loop;
             end if;
 
diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb
index 5baf128..1643e5c 100644
--- a/gcc/ada/s-taskin.adb
+++ b/gcc/ada/s-taskin.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNARL 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- --
@@ -205,18 +205,6 @@ package body System.Tasking is
          then System.Multiprocessors.Not_A_Specific_CPU
          else System.Multiprocessors.CPU_Range (Main_CPU));
 
-      T := STPO.New_ATCB (0);
-      Initialize_ATCB
-        (null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU,
-         null, Task_Info.Unspecified_Task_Info, 0, T, Success);
-      pragma Assert (Success);
-
-      STPO.Initialize (T);
-      STPO.Set_Priority (T, T.Common.Base_Priority);
-      T.Common.State := Runnable;
-      T.Common.Task_Image_Len := Main_Task_Image'Length;
-      T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image;
-
       --  At program start-up the environment task is allocated to the default
       --  system dispatching domain.
       --  Make sure that the processors which are not available are not taken
@@ -228,7 +216,27 @@ package body System.Tasking is
           (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs =>
              True);
 
-      T.Common.Domain := System_Domain;
+      T := STPO.New_ATCB (0);
+      Initialize_ATCB
+        (Self_ID => null,
+         Task_Entry_Point => null,
+         Task_Arg => Null_Address,
+         Parent => Null_Task,
+         Elaborated => null,
+         Base_Priority => Base_Priority,
+         Base_CPU => Base_CPU,
+         Domain => System_Domain,
+         Task_Info => Task_Info.Unspecified_Task_Info,
+         Stack_Size => 0,
+         T => T,
+         Success => Success);
+      pragma Assert (Success);
+
+      STPO.Initialize (T);
+      STPO.Set_Priority (T, T.Common.Base_Priority);
+      T.Common.State := Runnable;
+      T.Common.Task_Image_Len := Main_Task_Image'Length;
+      T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image;
 
       Dispatching_Domain_Tasks :=
         new Array_Allocated_Tasks'
diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads
index ffb96c3..a89fe6b 100644
--- a/gcc/ada/s-taskin.ads
+++ b/gcc/ada/s-taskin.ads
@@ -1178,9 +1178,11 @@ package System.Tasking is
       Stack_Size       : System.Parameters.Size_Type;
       T                : Task_Id;
       Success          : out Boolean);
-   --  Initialize fields of a TCB and link into global TCB structures Call
-   --  this only with abort deferred and holding RTS_Lock. Need more
-   --  documentation, mention T, and describe Success ???
+   --  Initialize fields of the TCB for task T, and link into global TCB
+   --  structures. Call this only with abort deferred and holding
+   --  RTS_Lock. Self_ID is the calling task (normally the activator of
+   --  T). Success is set to indicate whether the TCB was successfully
+   --  initialized. Need more documentation ???
 
 private
 
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 8a0ac8c..42e64b1 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -3550,10 +3550,19 @@ package body Sem_Ch13 is
             end if;
 
             --  Verify that the prefix of the attribute and the local name for
-            --  the type of the formal match.
+            --  the type of the formal match, or one is the class-wide of the
+            --  other, in the case of a class-wide stream operation.
 
-            if Base_Type (Typ) /= Base_Type (Ent)
-              or else Present (Next_Formal (F))
+            if  Base_Type (Typ) = Base_Type (Ent)
+              or else (Is_Class_Wide_Type (Typ)
+                and then Typ = Class_Wide_Type (Base_Type (Ent)))
+            then
+               null;
+            else
+               return False;
+            end if;
+
+            if Present ((Next_Formal (F)))
             then
                return False;
 
@@ -3635,12 +3644,14 @@ package body Sem_Ch13 is
             --  procedure (RM 13.13.2 (38/3)).
 
             elsif Is_Interface (U_Ent)
+              and then not Is_Class_Wide_Type (U_Ent)
               and then not Inside_A_Generic
-              and then Ekind (Subp) = E_Procedure
               and then
-                not Null_Present
-                  (Specification
-                     (Unit_Declaration_Node (Ultimate_Alias (Subp))))
+                (Ekind (Subp) = E_Function
+                  or else
+                    not Null_Present
+                      (Specification
+                         (Unit_Declaration_Node (Ultimate_Alias (Subp)))))
             then
                Error_Msg_N
                  ("stream subprogram for interface type "