[multiple changes]

2012-04-25  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch9.adb: Add comments on the usage of the
	lock-free data structures.

2012-04-25  Vincent Pucci  <pucci@adacore.com>

	* exp_intr.adb (Expand_Shift): Convert the left
	operand and the operator when the type of the call differs from
	the type of the operator.

2012-04-25  Geert Bosch  <bosch@adacore.com>

	* stand.ads: Minor comment fix.

2012-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch4.adb (Analyze_Slice): Handle the case where the prefix
	is a string literal. Retrieve the first index from the base type
	when slicing a string literal.
	* sem_ch12.adb (Check_Private_View): Move the initialization
	of the type inside the loop to reflect the changing index.
	* sem_eval.adb (Eval_Relational_Op): Retrieve the first index
	from the base type when dealing with a string literal.
	* sem_res.adb (Resolve_Slice): Retrieve the first index from
	the base type when slicing a string literal.
	* sem_util.adb (Is_Internally_Generated_Renaming): New routine.
	(Is_Object_Reference): String literals may act
	as object references only when they are renamed internally.
	(Proper_First_Index): New routine.
	* sem_util.ads (Proper_First_Index): New routine.

From-SVN: r186829

gcc/ada/ChangeLog

@@ -1,3 +1,35 @@
+2012-04-25  Gary Dismukes  <dismukes@adacore.com>
+
+	* exp_ch9.adb: Add comments on the usage of the
+	lock-free data structures.
+
+2012-04-25  Vincent Pucci  <pucci@adacore.com>
+
+	* exp_intr.adb (Expand_Shift): Convert the left
+	operand and the operator when the type of the call differs from
+	the type of the operator.
+
+2012-04-25  Geert Bosch  <bosch@adacore.com>
+
+	* stand.ads: Minor comment fix.
+
+2012-04-25  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_ch4.adb (Analyze_Slice): Handle the case where the prefix
+	is a string literal. Retrieve the first index from the base type
+	when slicing a string literal.
+	* sem_ch12.adb (Check_Private_View): Move the initialization
+	of the type inside the loop to reflect the changing index.
+	* sem_eval.adb (Eval_Relational_Op): Retrieve the first index
+	from the base type when dealing with a string literal.
+	* sem_res.adb (Resolve_Slice): Retrieve the first index from
+	the base type when slicing a string literal.
+	* sem_util.adb (Is_Internally_Generated_Renaming): New routine.
+	(Is_Object_Reference): String literals may act
+	as object references only when they are renamed internally.
+	(Proper_First_Index): New routine.
+	* sem_util.ads (Proper_First_Index): New routine.
+
 2012-04-25  Robert Dewar  <dewar@adacore.com>
 
 	* sem_ch3.adb, csinfo.adb, lib-writ.adb, sem_ch12.adb,

gcc/ada/exp_ch9.adb

@@ -81,16 +81,24 @@ package body Exp_Ch9 is
    -- Lock Free Data Structure --
    ------------------------------
 
+   --  A lock-free subprogram is a protected routine which references a unique
+   --  protected scalar component and does not contain statements that cause
+   --  side effects. Due to this restricted behavior, all references to shared
+   --  data from within the subprogram can be synchronized through the use of
+   --  atomic operations rather than relying on locks.
+
    type Lock_Free_Subprogram is record
       Sub_Body : Node_Id;
-      Comp_Id  : Entity_Id;
+      --  Reference to the body of a protected subprogram which meets the lock-
-   end record;
+      --  free requirements.
-   --  This data structure and its fields must be documented, ALL global
-   --  data structures must be documented. We never rely on guessing what
-   --  things mean from their names.
 
-   --  The following table establishes a relation between a subprogram body and
+      Comp_Id : Entity_Id;
-   --  an unique protected component referenced in this body.
+      --  Reference to the scalar component referenced from within Sub_Body
+   end record;
+
+   --  This table establishes a relation between a protected subprogram body
+   --  and a unique component it references. The table is used when building
+   --  the lock-free versions of a protected subprogram body.
 
    package Lock_Free_Subprogram_Table is new Table.Table (
      Table_Component_Type => Lock_Free_Subprogram,

gcc/ada/exp_intr.adb

@@ -650,20 +650,20 @@ package body Exp_Intr is
    --  and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
 
    procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
-      Loc   : constant Source_Ptr := Sloc (N);
+      Entyp : constant Entity_Id  := Etype (E);
-      Typ   : constant Entity_Id  := Etype (N);
       Left  : constant Node_Id    := First_Actual (N);
+      Loc   : constant Source_Ptr := Sloc (N);
       Right : constant Node_Id    := Next_Actual (Left);
       Ltyp  : constant Node_Id    := Etype (Left);
       Rtyp  : constant Node_Id    := Etype (Right);
+      Typ   : constant Entity_Id  := Etype (N);
       Snode : Node_Id;
 
    begin
       Snode := New_Node (K, Loc);
-      Set_Left_Opnd  (Snode, Relocate_Node (Left));
       Set_Right_Opnd (Snode, Relocate_Node (Right));
       Set_Chars      (Snode, Chars (E));
-      Set_Etype      (Snode, Base_Type (Typ));
+      Set_Etype      (Snode, Base_Type (Entyp));
       Set_Entity     (Snode, E);
 
       if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
@@ -672,12 +672,30 @@ package body Exp_Intr is
          Set_Shift_Count_OK (Snode, True);
       end if;
 
-      --  Do the rewrite. Note that we don't call Analyze and Resolve on
+      if Typ = Entyp then
-      --  this node, because it already got analyzed and resolved when
-      --  it was a function call!
 
-      Rewrite (N, Snode);
+         --  Note that we don't call Analyze and Resolve on this node, because
-      Set_Analyzed (N);
+         --  it already got analyzed and resolved when it was a function call.
+
+         Set_Left_Opnd (Snode, Relocate_Node (Left));
+         Rewrite (N, Snode);
+         Set_Analyzed (N);
+
+      else
+
+         --  If the context type is not the type of the operator, it is an
+         --  inherited operator for a derived type. Wrap the node in a
+         --  conversion so that it is type-consistent for possible further
+         --  expansion (e.g. within a lock-free protected type).
+
+         Set_Left_Opnd (Snode,
+           Unchecked_Convert_To (Base_Type (Entyp), Relocate_Node (Left)));
+         Rewrite (N, Unchecked_Convert_To (Typ, Snode));
+
+         --  Analyze and resolve result formed by conversion to target type
+
+         Analyze_And_Resolve (N, Typ);
+      end if;
    end Expand_Shift;
 
    ------------------------

gcc/ada/sem_ch12.adb

@@ -6128,8 +6128,9 @@ package body Sem_Ch12 is
 
             begin
                Indx := First_Index (T);
-               Typ  := Base_Type (Etype (Indx));
                while Present (Indx) loop
+                  Typ := Base_Type (Etype (Indx));
+
                   if Is_Private_Type (Typ)
                     and then Present (Full_View (Typ))
                   then

gcc/ada/sem_ch4.adb

@@ -4514,9 +4514,9 @@ package body Sem_Ch4 is
               ("type is not one-dimensional array in slice prefix", N);
 
          elsif not
-           Has_Compatible_Type (D, Etype (First_Index (Array_Type)))
+           Has_Compatible_Type (D, Etype (Proper_First_Index (Array_Type)))
          then
-            Wrong_Type (D, Etype (First_Index (Array_Type)));
+            Wrong_Type (D, Etype (Proper_First_Index (Array_Type)));
 
          else
             Set_Etype (N, Array_Type);

gcc/ada/sem_eval.adb

@@ -2747,7 +2747,7 @@ package body Sem_Eval is
 
                --  General case
 
-               T := Etype (First_Index (Etype (Op)));
+               T := Etype (Proper_First_Index (Etype (Op)));
 
                --  The simple case, both bounds are known at compile time
 

gcc/ada/sem_res.adb

@@ -9003,7 +9003,7 @@ package body Sem_Res is
       --  necessary. Else resolve the bounds, and apply needed checks.
 
       if not Is_Entity_Name (Drange) then
-         Index := First_Index (Array_Type);
+         Index := Proper_First_Index (Array_Type);
          Resolve (Drange, Base_Type (Etype (Index)));
 
          if Nkind (Drange) = N_Range then

gcc/ada/sem_util.adb

@@ -3573,7 +3573,6 @@ package body Sem_Util is
       if Present (C)
         and then Restriction_Check_Required (SPARK)
       then
-
          declare
             Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
             Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
@@ -7587,6 +7586,34 @@ package body Sem_Util is
    -------------------------
 
    function Is_Object_Reference (N : Node_Id) return Boolean is
+
+      function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
+      --  Determine whether N is the name of an internally-generated renaming
+
+      --------------------------------------
+      -- Is_Internally_Generated_Renaming --
+      --------------------------------------
+
+      function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
+         P : Node_Id := N;
+
+      begin
+         while Present (P) loop
+            if Nkind (P) = N_Object_Renaming_Declaration then
+               return not Comes_From_Source (P);
+
+            elsif Is_List_Member (P) then
+               return False;
+            end if;
+
+            P := Parent (P);
+         end loop;
+
+         return False;
+      end Is_Internally_Generated_Renaming;
+
+   --  Start of processing for Is_Object_Reference
+
    begin
       if Is_Entity_Name (N) then
          return Present (Entity (N)) and then Is_Object (Entity (N));
@@ -7633,6 +7660,14 @@ package body Sem_Util is
             when N_Unchecked_Type_Conversion =>
                return True;
 
+            --  Allow string literals to act as objects as long as they appear
+            --  in internally-generated renamings. The expansion of iterators
+            --  may generate such renamings when the range involves a string
+            --  literal.
+
+            when N_String_Literal =>
+               return Is_Internally_Generated_Renaming (Parent (N));
+
             when others =>
                return False;
          end case;
@@ -11619,6 +11654,21 @@ package body Sem_Util is
       Set_Sloc (Endl, Loc);
    end Process_End_Label;
 
+   ------------------------
+   -- Proper_First_Index --
+   ------------------------
+
+   function Proper_First_Index (Array_Typ : Entity_Id) return Entity_Id is
+      Typ : Entity_Id := Array_Typ;
+
+   begin
+      if Ekind (Typ) = E_String_Literal_Subtype then
+         Typ := Base_Type (Typ);
+      end if;
+
+      return First_Index (Typ);
+   end Proper_First_Index;
+
    ------------------------------------
    -- References_Generic_Formal_Type --
    ------------------------------------

gcc/ada/sem_util.ads

@@ -1284,6 +1284,11 @@ package Sem_Util is
    --  parameter Ent gives the entity to which the End_Label refers,
    --  and to which cross-references are to be generated.
 
+   function Proper_First_Index (Array_Typ : Entity_Id) return Entity_Id;
+   --  Return the First_Index attribute of an arbitrary array type unless it
+   --  is a string literal subtype in which case return the First_Index of the
+   --  base type.
+
    function References_Generic_Formal_Type (N : Node_Id) return Boolean;
    --  Returns True if the expression Expr contains any references to a
    --  generic type. This can only happen within a generic template.

gcc/ada/stand.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -460,12 +460,12 @@ package Stand is
    -----------------
 
    procedure Tree_Read;
-   --  Initializes entity values in this package from the current tree
+   --  Initializes entity values in this package from the current tree file
-   --  file using Osint.Tree_Read. Note that Tree_Read includes all the
+   --  using Tree_IO. Note that Tree_Read includes all the initialization that
-   --  initialization that is carried out by Create_Standard.
+   --  is carried out by Create_Standard.
 
    procedure Tree_Write;
    --  Writes out the entity values in this package to the current tree file
-   --  using Osint.Tree_Write.
+   --  using Tree_IO.
 
 end Stand;