2008-04-08 Hristian Kirtchev <kirtchev@adacore.com>

	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* exp_ch9.ads, exp_ch9.adb (Build_Protected_Entry,
	Build_Unprotected_Subprogram_Body): Generate debug info for
	declarations related to the handling of private data in task and
	protected types.
	(Debug_Private_Data_Declarations): New subprogram.
	(Install_Private_Data_Declarations): Remove all debug info flagging.
	This is now done by Debug_Private_Data_Declarations at the correct
	stage of expansion.
	(Build_Simple_Entry_Call): If the task name is a function call, expand
	the prefix into an object declaration, and make the surrounding block a
	task master.
	(Build_Master_Entity): An internal block is a master if it wraps a call.
	Code reformatting, update comments. Code clean up.
	(Make_Task_Create_Call): Use 'Unrestricted_Access instead of 'Address.
	(Replicate_Entry_Formals): If the formal is an access parameter or
	anonymous access to subprogram, copy the original tree to create new
	entities for the formals of the subprogram.
	(Expand_N_Task_Type_Declaration): Create a Relative_Deadline variable
	for tasks to store the value passed using pragma Relative_Deadline.
	(Make_Task_Create_Call): Add the Relative_Deadline argument to the
	run-time call to create a task.
	(Build_Wrapper_Spec): If the controlling argument of the interface
	operation is an access parameter with a non-null indicator, use the
	non-null indicator on the wrapper.

	* sem_ch9.adb (Analyze_Protected_Type): Only retrieve the full view when
	present, which it may not be in the case where the type entity is an
	incomplete view brought in by a limited with.
	(Analyze_Task_Type): Only retrieve the full view when present, which it
	may not be in the case where the type entity is an incomplete view
	brought in by a limited with.
	(Analyze_Protected_Definition): Set Is_Frozen on all itypes generated for
	private components of a protected type, to prevent the generation of
	freeze nodes for which there is no proper scope of elaboration.

	* exp_util.ads, exp_util.adb (Remove_Side_Effects): If the expression is
	a function call that returns a task, expand into a declaration to invoke
	the build_in_place machinery.
	(Find_Protection_Object): New routine.
	(Remove_Side_Effects): Also make a copy of the value
	for attributes whose result is of an elementary type.
	(Silly_Boolean_Array_Not_Test): New procedure
	(Silly_Boolean_Array_Xor_Test): New procedure
	(Is_Volatile_Reference): New function
	(Remove_Side_Effects): Use Is_Volatile_Reference
	(Possible_Bit_Aligned_Component): Handle slice case properly

	* exp_pakd.adb (Expand_Packed_Not): Move silly true/true or false/false
	case test to Exp_Util
	(Expand_Packed_Xor): Move silly true/true case test to Exp_Util



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@134030 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 222 insertions, 35 deletions

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 82f3fcfc201..12fea51a197 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -336,7 +336,7 @@ package body Exp_Util is
    --  component, whose prefix is the outer variable of the array type.
    --  The n-dimensional array type has known indices Index, Index2...
    --  Id_Ref is an indexed component form created by the enclosing init proc.
-   --  Its successive indices are Val1, Val2,.. which are the loop variables
+   --  Its successive indices are Val1, Val2, ... which are the loop variables
    --  in the loops that call the individual task init proc on each component.
 
    --  The generated function has the following structure:
@@ -962,9 +962,16 @@ package body Exp_Util is
          if Has_Entries (Typ)
            or else Has_Interrupt_Handler (Typ)
            or else (Has_Attach_Handler (Typ)
-                     and then not Restricted_Profile)
-           or else (Ada_Version >= Ada_05
-                     and then Present (Interface_List (Parent (Typ))))
+                      and then not Restricted_Profile)
+
+            --  A protected type without entries that covers an interface and
+            --  overrides the abstract routines with protected procedures is
+            --  considered equivalent to a protected type with entries in the
+            --  context of dispatching select statements. It is sufficent to
+            --  check for the presence of an interface list in the declaration
+            --  node to recognize this case.
+
+           or else Present (Interface_List (Parent (Typ)))
          then
             if Abort_Allowed
               or else Restriction_Active (No_Entry_Queue) = False
@@ -1814,6 +1821,34 @@ package body Exp_Util is
       return Node (Prim);
    end Find_Prim_Op;
 
+   ----------------------------
+   -- Find_Protection_Object --
+   ----------------------------
+
+   function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
+      S : Entity_Id;
+
+   begin
+      S := Scop;
+      while Present (S) loop
+         if (Ekind (S) = E_Entry
+               or else Ekind (S) = E_Entry_Family
+               or else Ekind (S) = E_Function
+               or else Ekind (S) = E_Procedure)
+           and then Present (Protection_Object (S))
+         then
+            return Protection_Object (S);
+         end if;
+
+         S := Scope (S);
+      end loop;
+
+      --  If we do not find a Protection object in the scope chain, then
+      --  something has gone wrong, most likely the object was never created.
+
+      raise Program_Error;
+   end Find_Protection_Object;
+
    ----------------------
    -- Force_Evaluation --
    ----------------------
@@ -2292,13 +2327,14 @@ package body Exp_Util is
          return;
       end if;
 
-      --  Ignore insert of actions from inside default expression in the
-      --  special preliminary analyze mode. Any insertions at this point
-      --  have no relevance, since we are only doing the analyze to freeze
-      --  the types of any static expressions. See section "Handling of
-      --  Default Expressions" in the spec of package Sem for further details.
+      --  Ignore insert of actions from inside default expression (or other
+      --  similar "spec expression") in the special spec-expression analyze
+      --  mode. Any insertions at this point have no relevance, since we are
+      --  only doing the analyze to freeze the types of any static expressions.
+      --  See section "Handling of Default Expressions" in the spec of package
+      --  Sem for further details.
 
-      if In_Default_Expression then
+      if In_Spec_Expression then
          return;
       end if;
 
@@ -3028,6 +3064,10 @@ package body Exp_Util is
 
       Get_Name_String (Chars (E));
 
+      --  Most predefined primitives have internally generated names. Equality
+      --  must be treated differently; the predefined operation is recognized
+      --  as a homgeneous binary operator that returns Boolean.
+
       if Name_Len > TSS_Name_Type'Last then
          TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
                                      .. Name_Len));
@@ -3441,6 +3481,40 @@ package body Exp_Util is
                and then Etype (Full_View (T)) /= T);
    end Is_Untagged_Derivation;
 
+   ---------------------------
+   -- Is_Volatile_Reference --
+   ---------------------------
+
+   function Is_Volatile_Reference (N : Node_Id) return Boolean is
+   begin
+      if Nkind (N) in N_Has_Etype
+        and then Present (Etype (N))
+        and then Treat_As_Volatile (Etype (N))
+      then
+         return True;
+
+      elsif Is_Entity_Name (N) then
+         return Treat_As_Volatile (Entity (N));
+
+      elsif Nkind (N) = N_Slice then
+         return Is_Volatile_Reference (Prefix (N));
+
+      elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
+         if (Is_Entity_Name (Prefix (N))
+               and then Has_Volatile_Components (Entity (Prefix (N))))
+           or else (Present (Etype (Prefix (N)))
+                      and then Has_Volatile_Components (Etype (Prefix (N))))
+         then
+            return True;
+         else
+            return Is_Volatile_Reference (Prefix (N));
+         end if;
+
+      else
+         return False;
+      end if;
+   end Is_Volatile_Reference;
+
    --------------------
    -- Kill_Dead_Code --
    --------------------
@@ -4257,9 +4331,15 @@ package body Exp_Util is
                end if;
             end;
 
-         --  If we have neither a record nor array component, it means that we
-         --  have fallen off the top testing prefixes recursively, and we now
-         --  have a stand alone object, where we don't have a problem.
+         --  For a slice, test the prefix, if that is possibly misaligned,
+         --  then for sure the slice is!
+
+         when N_Slice =>
+            return Possible_Bit_Aligned_Component (Prefix (N));
+
+         --  If we have none of the above, it means that we have fallen off the
+         --  top testing prefixes recursively, and we now have a stand alone
+         --  object, where we don't have a problem.
 
          when others =>
             return False;
@@ -4375,7 +4455,7 @@ package body Exp_Util is
          --  hand, if we do not consider them to be side effect free, then
          --  we get some awkward expansions in -gnato mode, resulting in
          --  code insertions at a point where we do not have a clear model
-         --  for performing the insertions. See 4908-002/comment for details.
+         --  for performing the insertions.
 
          --  Special handling for entity names
 
@@ -4399,14 +4479,13 @@ package body Exp_Util is
                return False;
 
             --  Variables are considered to be a side effect if Variable_Ref
-            --  is set or if we have a volatile variable and Name_Req is off.
+            --  is set or if we have a volatile reference and Name_Req is off.
             --  If Name_Req is True then we can't help returning a name which
             --  effectively allows multiple references in any case.
 
             elsif Is_Variable (N) then
                return not Variable_Ref
-                 and then (not Treat_As_Volatile (Entity (N))
-                             or else Name_Req);
+                 and then (not Is_Volatile_Reference (N) or else Name_Req);
 
             --  Any other entity (e.g. a subtype name) is definitely side
             --  effect free.
@@ -4631,17 +4710,16 @@ package body Exp_Util is
       Scope_Suppress := (others => True);
 
       --  If it is a scalar type and we need to capture the value, just make
-      --  a copy. Likewise for a function or operator call. And if we have a
-      --  volatile variable and Nam_Req is not set (see comments above for
-      --  Side_Effect_Free).
+      --  a copy. Likewise for a function call, an attribute reference or an
+      --  operator. And if we have a volatile reference and Name_Req is not
+      --  set (see comments above for Side_Effect_Free).
 
       if Is_Elementary_Type (Exp_Type)
         and then (Variable_Ref
                    or else Nkind (Exp) = N_Function_Call
+                   or else Nkind (Exp) = N_Attribute_Reference
                    or else Nkind (Exp) in N_Op
-                   or else (not Name_Req
-                             and then Is_Entity_Name (Exp)
-                             and then Treat_As_Volatile (Entity (Exp))))
+                   or else (not Name_Req and then Is_Volatile_Reference (Exp)))
       then
          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
          Set_Etype (Def_Id, Exp_Type);
@@ -4686,9 +4764,9 @@ package body Exp_Util is
 
       --  If this is a type conversion, leave the type conversion and remove
       --  the side effects in the expression. This is important in several
-      --  circumstances: for change of representations, and also when this
-      --  is a view conversion to a smaller object, where gigi can end up
-      --  creating its own temporary of the wrong size.
+      --  circumstances: for change of representations, and also when this is
+      --  a view conversion to a smaller object, where gigi can end up creating
+      --  its own temporary of the wrong size.
 
       elsif Nkind (Exp) = N_Type_Conversion then
          Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
@@ -4732,14 +4810,12 @@ package body Exp_Util is
          end if;
 
       --  For expressions that denote objects, we can use a renaming scheme.
-      --  We skip using this if we have a volatile variable and we do not
-      --  have Nam_Req set true (see comments above for Side_Effect_Free).
+      --  We skip using this if we have a volatile reference and we do not
+      --  have Name_Req set true (see comments above for Side_Effect_Free).
 
       elsif Is_Object_Reference (Exp)
         and then Nkind (Exp) /= N_Function_Call
-        and then (Name_Req
-                   or else not Is_Entity_Name (Exp)
-                   or else not Treat_As_Volatile (Entity (Exp)))
+        and then (Name_Req or else not Is_Volatile_Reference (Exp))
       then
          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
 
@@ -4778,7 +4854,7 @@ package body Exp_Util is
          --  If this is a packed reference, or a selected component with a
          --  non-standard representation, a reference to the temporary will
          --  be replaced by a copy of the original expression (see
-         --  exp_ch2.Expand_Renaming). Otherwise the temporary must be
+         --  Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
          --  elaborated by gigi, and is of course not to be replaced in-line
          --  by the expression it renames, which would defeat the purpose of
          --  removing the side-effect.
@@ -4795,6 +4871,36 @@ package body Exp_Util is
       --  Otherwise we generate a reference to the value
 
       else
+         --  Special processing for function calls that return a task. We need
+         --  to build a declaration that will enable build-in-place expansion
+         --  of the call.
+
+         --  This is relevant only in Ada 2005 mode. In Ada 95 programs we have
+         --  to accommodate functions returning limited objects by reference.
+
+         if Nkind (Exp) = N_Function_Call
+           and then Is_Task_Type (Etype (Exp))
+           and then Ada_Version >= Ada_05
+         then
+            declare
+               Obj  : constant Entity_Id :=
+                        Make_Defining_Identifier (Loc,
+                          Chars => New_Internal_Name ('F'));
+               Decl : Node_Id;
+
+            begin
+               Decl :=
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Obj,
+                   Object_Definition   => New_Occurrence_Of (Exp_Type, Loc),
+                   Expression          => Relocate_Node (Exp));
+               Insert_Action (Exp, Decl);
+               Set_Etype (Obj, Exp_Type);
+               Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
+               return;
+            end;
+         end if;
+
          Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
 
          Ptr_Typ_Decl :=
@@ -5202,9 +5308,9 @@ package body Exp_Util is
 
             Analyze (Asn);
 
-            --  Kill current value indication. This is necessary because
-            --  the tests of this flag are inserted out of sequence and must
-            --  not pick up bogus indications of the wrong constant value.
+            --  Kill current value indication. This is necessary because the
+            --  tests of this flag are inserted out of sequence and must not
+            --  pick up bogus indications of the wrong constant value.
 
             Set_Current_Value (Ent, Empty);
          end if;
@@ -5237,6 +5343,87 @@ package body Exp_Util is
       end if;
    end Set_Renamed_Subprogram;
 
+   ----------------------------------
+   -- Silly_Boolean_Array_Not_Test --
+   ----------------------------------
+
+   --  This procedure implements an odd and silly test. We explicitly check
+   --  for the case where the 'First of the component type is equal to the
+   --  'Last of this component type, and if this is the case, we make sure
+   --  that constraint error is raised. The reason is that the NOT is bound
+   --  to cause CE in this case, and we will not otherwise catch it.
+
+   --  Believe it or not, this was reported as a bug. Note that nearly
+   --  always, the test will evaluate statically to False, so the code will
+   --  be statically removed, and no extra overhead caused.
+
+   procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
+      Loc : constant Source_Ptr := Sloc (N);
+      CT  : constant Entity_Id  := Component_Type (T);
+
+   begin
+      Insert_Action (N,
+        Make_Raise_Constraint_Error (Loc,
+          Condition =>
+            Make_Op_Eq (Loc,
+              Left_Opnd =>
+                Make_Attribute_Reference (Loc,
+                  Prefix         => New_Occurrence_Of (CT, Loc),
+                  Attribute_Name => Name_First),
+
+              Right_Opnd =>
+                Make_Attribute_Reference (Loc,
+                  Prefix         => New_Occurrence_Of (CT, Loc),
+                  Attribute_Name => Name_Last)),
+          Reason => CE_Range_Check_Failed));
+   end Silly_Boolean_Array_Not_Test;
+
+   ----------------------------------
+   -- Silly_Boolean_Array_Xor_Test --
+   ----------------------------------
+
+   --  This procedure implements an odd and silly test. We explicitly check
+   --  for the XOR case where the component type is True .. True, since this
+   --  will raise constraint error. A special check is required since CE
+   --  will not be required otherwise (cf Expand_Packed_Not).
+
+   --  No such check is required for AND and OR, since for both these cases
+   --  False op False = False, and True op True = True.
+
+   procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
+      Loc : constant Source_Ptr := Sloc (N);
+      CT  : constant Entity_Id  := Component_Type (T);
+      BT  : constant Entity_Id  := Base_Type (CT);
+
+   begin
+      Insert_Action (N,
+        Make_Raise_Constraint_Error (Loc,
+          Condition =>
+            Make_Op_And (Loc,
+              Left_Opnd =>
+                Make_Op_Eq (Loc,
+                  Left_Opnd =>
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => New_Occurrence_Of (CT, Loc),
+                      Attribute_Name => Name_First),
+
+                  Right_Opnd =>
+                    Convert_To (BT,
+                      New_Occurrence_Of (Standard_True, Loc))),
+
+              Right_Opnd =>
+                Make_Op_Eq (Loc,
+                  Left_Opnd =>
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => New_Occurrence_Of (CT, Loc),
+                      Attribute_Name => Name_Last),
+
+                  Right_Opnd =>
+                    Convert_To (BT,
+                      New_Occurrence_Of (Standard_True, Loc)))),
+          Reason => CE_Range_Check_Failed));
+   end Silly_Boolean_Array_Xor_Test;
+
    --------------------------
    -- Target_Has_Fixed_Ops --
    --------------------------