einfo.adb (Is_Thunk): New attribute applicable to subprograms.

2007-09-26  Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* einfo.adb (Is_Thunk): New attribute applicable to subprograms. True
	for thunks associated with interface types.

	* einfo.ads: Improve documentatation of Is_Internal
	(Is_Thunk): New attribute applicable to subprograms. True for thunks
	associated with interface types.
	Extensive comment fixes regarding flags that appear in all entities. The
	documentation is now consistent for all such flags (there were a number
	of errors in the documentation in this regard).

	* exp_attr.adb (Expand_N_Attribute_Reference): Minor code cleanup.

	* exp_ch6.adb (Make_Build_In_Place_Call_*): Return immediately if any
	of these procedures are passed a function call that already has
	build-in-place actuals (testing new flag
	Is_Expanded_Build_In_Place_Call). Set the flag on the function call in
	the case where processing continues.
	(Expand_Call): If the call is generated from a thunk body then we
	propagate the extra actuals associated with the accessibility
	level of the access type actuals.

	* sem_ch6.adb (Analyze_Subprogram_Body): Set the Protected_Formal field
	of each extra formal of a protected operation to reference the
	corresponding extra formal of the subprogram denoted by the
	operation's Protected_Body_Subprogram.
	
	* sinfo.ads, sinfo.adb (Is_Expanded_Build_In_Place_Call): New flag on
	N_Function_Call nodes.

From-SVN: r128786

gcc/ada/einfo.adb

@@ -483,7 +483,8 @@ package body Einfo is
    --    Used_As_Generic_Actual          Flag222
    --    Is_Descendent_Of_Address        Flag223
    --    Is_Raised                       Flag224
-   --    (unused)                        Flag225
+   --    Is_Thunk                        Flag225
+   --
    --    (unused)                        Flag226
    --    (unused)                        Flag227
    --    (unused)                        Flag228
@@ -1966,6 +1967,12 @@ package body Einfo is
       return Flag200 (Id);
    end Is_Task_Interface;
 
+   function Is_Thunk (Id : E) return B is
+   begin
+      pragma Assert (Is_Subprogram (Id));
+      return Flag225 (Id);
+   end Is_Thunk;
+
    function Is_True_Constant (Id : E) return B is
    begin
       return Flag163 (Id);
@@ -4291,6 +4298,11 @@ package body Einfo is
       Set_Flag200 (Id, V);
    end Set_Is_Task_Interface;
 
+   procedure Set_Is_Thunk (Id : E; V : B := True) is
+   begin
+      Set_Flag225 (Id, V);
+   end Set_Is_Thunk;
+
    procedure Set_Is_True_Constant (Id : E; V : B := True) is
    begin
       Set_Flag163 (Id, V);
@@ -7264,6 +7276,7 @@ package body Einfo is
       W ("Is_Tag",                          Flag78  (Id));
       W ("Is_Tagged_Type",                  Flag55  (Id));
       W ("Is_Task_Interface",               Flag200 (Id));
+      W ("Is_Thunk",                        Flag225 (Id));
       W ("Is_True_Constant",                Flag163 (Id));
       W ("Is_Unchecked_Union",              Flag117 (Id));
       W ("Is_Unsigned_Type",                Flag144 (Id));

gcc/ada/exp_attr.adb

@@ -637,12 +637,10 @@ package body Exp_Attr is
                   pragma Assert (Present (Formal));
 
                   Rewrite (N,
-                    Unchecked_Convert_To
-                      (Typ, New_Occurrence_Of (Formal, Loc)));
+                    Unchecked_Convert_To (Typ,
+                      New_Occurrence_Of (Formal, Loc)));
                   Set_Etype (N, Typ);
 
-                  return;
-
                --  The expression must appear in a default expression, (which
                --  in the initialization procedure is the right-hand side of an
                --  assignment), and not in a discriminant constraint.
@@ -667,8 +665,6 @@ package body Exp_Attr is
 
                      Analyze_And_Resolve (N, Typ);
                   end if;
-
-                  return;
                end if;
             end;
 
@@ -702,8 +698,8 @@ package body Exp_Attr is
                --  Note: Limit the expansion of an attribute applied to a
                --  dereference of an access parameter so that it's only done
                --  for 'Access. This fixes a problem with 'Unrestricted_Access
-               --  that leads to errors in the case where the attribute
-               --  type is access-to-variable and the access parameter is
+               --  that leads to errors in the case where the attribute type
+               --  is access-to-variable and the access parameter is
                --  access-to-constant. The conversion is only done to get
                --  accessibility checks, so it makes sense to limit it to
                --  'Access (and consistent with existing comment).

gcc/ada/exp_ch6.adb

@@ -1679,25 +1679,8 @@ package body Exp_Ch6 is
 
    procedure Expand_Call (N : Node_Id) is
       Loc           : constant Source_Ptr := Sloc (N);
-      Remote        : constant Boolean    := Is_Remote_Call (N);
-      Subp          : Entity_Id;
-      Orig_Subp     : Entity_Id := Empty;
-      Parent_Subp   : Entity_Id;
-      Parent_Formal : Entity_Id;
-      Actual        : Node_Id;
-      Formal        : Entity_Id;
-      Prev          : Node_Id := Empty;
-
-      Prev_Orig : Node_Id;
-      --  Original node for an actual, which may have been rewritten. If the
-      --  actual is a function call that has been transformed from a selected
-      --  component, the original node is unanalyzed. Otherwise, it carries
-      --  semantic information used to generate additional actuals.
-
-      Scop          : Entity_Id;
       Extra_Actuals : List_Id := No_List;
-
-      CW_Interface_Formals_Present : Boolean := False;
+      Prev          : Node_Id := Empty;
 
       procedure Add_Actual_Parameter (Insert_Param : Node_Id);
       --  Adds one entry to the end of the actual parameter list. Used for
@@ -1878,6 +1861,26 @@ package body Exp_Ch6 is
          raise Program_Error;
       end Inherited_From_Formal;
 
+      --  Local variables
+
+      Remote        : constant Boolean := Is_Remote_Call (N);
+      Actual        : Node_Id;
+      Formal        : Entity_Id;
+      Orig_Subp     : Entity_Id := Empty;
+      Param_Count   : Natural := 0;
+      Parent_Formal : Entity_Id;
+      Parent_Subp   : Entity_Id;
+      Scop          : Entity_Id;
+      Subp          : Entity_Id;
+
+      Prev_Orig     : Node_Id;
+      --  Original node for an actual, which may have been rewritten. If the
+      --  actual is a function call that has been transformed from a selected
+      --  component, the original node is unanalyzed. Otherwise, it carries
+      --  semantic information used to generate additional actuals.
+
+      CW_Interface_Formals_Present : Boolean := False;
+
    --  Start of processing for Expand_Call
 
    begin
@@ -1998,8 +2001,9 @@ package body Exp_Ch6 is
       --  We also generate any required range checks for actuals as we go
       --  through the loop, since this is a convenient place to do this.
 
-      Formal := First_Formal (Subp);
-      Actual := First_Actual (N);
+      Formal      := First_Formal (Subp);
+      Actual      := First_Actual (N);
+      Param_Count := 1;
       while Present (Formal) loop
 
          --  Generate range check if required (not activated yet ???)
@@ -2136,7 +2140,35 @@ package body Exp_Ch6 is
                Prev_Orig := Prev;
             end if;
 
-            if Is_Entity_Name (Prev_Orig) then
+            --  Ada 2005 (AI-251): Thunks must propagate the extra actuals
+            --  of accessibility levels.
+
+            if Ekind (Current_Scope) in Subprogram_Kind
+              and then Is_Thunk (Current_Scope)
+            then
+               declare
+                  Parm_Ent : Entity_Id;
+
+               begin
+                  if Is_Controlling_Actual (Actual) then
+
+                     --  Find the corresponding actual of the thunk
+
+                     Parm_Ent := First_Entity (Current_Scope);
+                     for J in 2 .. Param_Count loop
+                        Next_Entity (Parm_Ent);
+                     end loop;
+
+                  else pragma Assert (Is_Entity_Name (Actual));
+                     Parm_Ent := Entity (Actual);
+                  end if;
+
+                  Add_Extra_Actual
+                    (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc),
+                     Extra_Accessibility (Formal));
+               end;
+
+            elsif Is_Entity_Name (Prev_Orig) then
 
                --  When passing an access parameter, or a renaming of an access
                --  parameter, as the actual to another access parameter we need
@@ -2191,11 +2223,12 @@ package body Exp_Ch6 is
                      Extra_Accessibility (Formal));
                end if;
 
+            --  All cases other than thunks
+
             else
                case Nkind (Prev_Orig) is
 
                   when N_Attribute_Reference =>
-
                      case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
 
                         --  For X'Access, pass on the level of the prefix X
@@ -2411,6 +2444,7 @@ package body Exp_Ch6 is
 
          <<Skip_Extra_Actual_Generation>>
 
+         Param_Count := Param_Count + 1;
          Next_Actual (Actual);
          Next_Formal (Formal);
       end loop;
@@ -5038,6 +5072,18 @@ package body Exp_Ch6 is
          Func_Call := Expression (Func_Call);
       end if;
 
+      --  If the call has already been processed to add build-in-place actuals
+      --  then return. This should not normally occur in an allocator context,
+      --  but we add the protection as a defensive measure.
+
+      if Is_Expanded_Build_In_Place_Call (Func_Call) then
+         return;
+      end if;
+
+      --  Mark the call as processed as a build-in-place call
+
+      Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
       Loc := Sloc (Function_Call);
 
       if Is_Entity_Name (Name (Func_Call)) then
@@ -5179,6 +5225,20 @@ package body Exp_Ch6 is
          Func_Call := Expression (Func_Call);
       end if;
 
+      --  If the call has already been processed to add build-in-place actuals
+      --  then return. One place this can occur is for calls to build-in-place
+      --  functions that occur within a call to a protected operation, where
+      --  due to rewriting and expansion of the protected call there can be
+      --  more than one call to Expand_Actuals for the same set of actuals.
+
+      if Is_Expanded_Build_In_Place_Call (Func_Call) then
+         return;
+      end if;
+
+      --  Mark the call as processed as a build-in-place call
+
+      Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
       Loc := Sloc (Function_Call);
 
       if Is_Entity_Name (Name (Func_Call)) then
@@ -5293,6 +5353,18 @@ package body Exp_Ch6 is
          Func_Call := Expression (Func_Call);
       end if;
 
+      --  If the call has already been processed to add build-in-place actuals
+      --  then return. This should not normally occur in an assignment context,
+      --  but we add the protection as a defensive measure.
+
+      if Is_Expanded_Build_In_Place_Call (Func_Call) then
+         return;
+      end if;
+
+      --  Mark the call as processed as a build-in-place call
+
+      Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
       Loc := Sloc (Function_Call);
 
       if Is_Entity_Name (Name (Func_Call)) then
@@ -5403,6 +5475,18 @@ package body Exp_Ch6 is
          Func_Call := Expression (Func_Call);
       end if;
 
+      --  If the call has already been processed to add build-in-place actuals
+      --  then return. This should not normally occur in an object declaration,
+      --  but we add the protection as a defensive measure.
+
+      if Is_Expanded_Build_In_Place_Call (Func_Call) then
+         return;
+      end if;
+
+      --  Mark the call as processed as a build-in-place call
+
+      Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
       Loc := Sloc (Function_Call);
 
       if Is_Entity_Name (Name (Func_Call)) then

gcc/ada/sem_ch6.adb

@@ -1961,6 +1961,37 @@ package body Sem_Ch6 is
 
       Check_Anonymous_Return;
 
+      --  Set the Protected_Formal field of each extra formal of the protected
+      --  subprogram to reference the corresponding extra formal of the
+      --  subprogram that implements it. For regular formals this occurs when
+      --  the protected subprogram's declaration is expanded, but the extra
+      --  formals don't get created until the subprogram is frozen. We need to
+      --  do this before analyzing the protected subprogram's body so that any
+      --  references to the original subprogram's extra formals will be changed
+      --  refer to the implementing subprogram's formals (see Expand_Formal).
+
+      if Present (Spec_Id)
+        and then Is_Protected_Type (Scope (Spec_Id))
+        and then Present (Protected_Body_Subprogram (Spec_Id))
+      then
+         declare
+            Impl_Subp       : constant Entity_Id :=
+                                Protected_Body_Subprogram (Spec_Id);
+            Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id);
+            Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp);
+
+         begin
+            while Present (Prot_Ext_Formal) loop
+               pragma Assert (Present (Impl_Ext_Formal));
+
+               Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
+
+               Next_Formal_With_Extras (Prot_Ext_Formal);
+               Next_Formal_With_Extras (Impl_Ext_Formal);
+            end loop;
+         end;
+      end if;
+
       --  Now we can go on to analyze the body
 
       HSS := Handled_Statement_Sequence (N);

gcc/ada/sinfo.adb

@@ -185,6 +185,14 @@ package body Sinfo is
       return Node4 (N);
    end Actual_Designated_Subtype;
 
+   function Address_Warning_Posted
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Definition_Clause);
+      return Flag18 (N);
+   end Address_Warning_Posted;
+
    function Aggregate_Bounds
       (N : Node_Id) return Node_Id is
    begin
@@ -1590,6 +1598,14 @@ package body Sinfo is
       return Flag8 (N);
    end Is_Entry_Barrier_Function;
 
+   function Is_Expanded_Build_In_Place_Call
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Call);
+      return Flag11 (N);
+   end Is_Expanded_Build_In_Place_Call;
+
    function Is_Folded_In_Parser
       (N : Node_Id) return Boolean is
    begin
@@ -2901,6 +2917,14 @@ package body Sinfo is
       Set_Node4 (N, Val);
    end Set_Actual_Designated_Subtype;
 
+   procedure Set_Address_Warning_Posted
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Definition_Clause);
+      Set_Flag18 (N, Val);
+   end Set_Address_Warning_Posted;
+
    procedure Set_Aggregate_Bounds
       (N : Node_Id; Val : Node_Id) is
    begin
@@ -4297,6 +4321,14 @@ package body Sinfo is
       Set_Flag8 (N, Val);
    end Set_Is_Entry_Barrier_Function;
 
+   procedure Set_Is_Expanded_Build_In_Place_Call
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Call);
+      Set_Flag11 (N, Val);
+   end Set_Is_Expanded_Build_In_Place_Call;
+
    procedure Set_Is_Folded_In_Parser
       (N : Node_Id; Val : Boolean := True) is
    begin

gcc/ada/sinfo.ads

@@ -475,17 +475,6 @@ package Sinfo is
    --    refers to a node or is posted on its source location, and has the
    --    effect of inhibiting further messages involving this same node.
 
-   --  Local_Raise_Statements (Elist1)
-   --    This field is present in exception handler nodes. It is set to
-   --    No_Elist in the normal case. If there is at least one raise statement
-   --    which can potentially be handled as a local raise, then this field
-   --    points to a list of raise nodes, which are calls to a routine to raise
-   --    an exception. These are raise nodes which can be optimized into gotos
-   --    if the handler turns out to meet the conditions which permit this
-   --    transformation. Note that this does NOT include instances of the
-   --    N_Raise_xxx_Error nodes since the transformation of these nodes is
-   --    handled by the back end (using the N_Push/N_Pop mechanism).
-
    --  Has_Dynamic_Length_Check (Flag10-Sem)
    --    This flag is present on all nodes. It is set to indicate that one of
    --    the routines in unit Checks has generated a length check action which
@@ -573,6 +562,11 @@ package Sinfo is
    --    the designated type is an unconstrained packed array and the
    --    dereference is the prefix of a 'Size attribute reference.
 
+   --  Address_Warning_Posted (Flag18-Sem)
+   --    Present in N_Attribute_Definition nodes. Set to indicate that we have
+   --    posted a warning for the address clause regarding size or alignment
+   --    issues. Used to inhibit multiple redundant messages.
+
    --  Aggregate_Bounds (Node3-Sem)
    --    Present in array N_Aggregate nodes. If the aggregate contains
    --    component associations this field points to an N_Range node whose
@@ -1167,6 +1161,11 @@ package Sinfo is
    --    of an entry barrier from a protected entry body. It is used for the
    --    circuitry checking for incorrect use of Current_Task.
 
+   --  Is_Expanded_Build_In_Place_Call (Flag11-Sem)
+   --    This flag is set in an N_Function_Call node to indicate that the extra
+   --    actuals to support a build-in-place style of call have been added to
+   --    the call.
+
    --  Is_In_Discriminant_Check (Flag11-Sem)
    --    This flag is present in a selected component, and is used to indicate
    --    that the reference occurs within a discriminant check. The
@@ -1282,6 +1281,17 @@ package Sinfo is
    --    described above). Instead for a child unit, implicit with's are
    --    generated for all parents.
 
+   --  Local_Raise_Statements (Elist1)
+   --    This field is present in exception handler nodes. It is set to
+   --    No_Elist in the normal case. If there is at least one raise statement
+   --    which can potentially be handled as a local raise, then this field
+   --    points to a list of raise nodes, which are calls to a routine to raise
+   --    an exception. These are raise nodes which can be optimized into gotos
+   --    if the handler turns out to meet the conditions which permit this
+   --    transformation. Note that this does NOT include instances of the
+   --    N_Raise_xxx_Error nodes since the transformation of these nodes is
+   --    handled by the back end (using the N_Push/N_Pop mechanism).
+
    --  Loop_Actions (List2-Sem)
    --    A list present in Component_Association nodes in array aggregates.
    --    Used to collect actions that must be executed within the loop because
@@ -4295,6 +4305,7 @@ package Sinfo is
       --   actual parameter part)
       --  First_Named_Actual (Node4-Sem)
       --  Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+      --  Is_Expanded_Build_In_Place_Call (Flag11-Sem)
       --  Do_Tag_Check (Flag13-Sem)
       --  No_Elaboration_Check (Flag14-Sem)
       --  Parameter_List_Truncated (Flag17-Sem)
@@ -6114,6 +6125,7 @@ package Sinfo is
       --  Next_Rep_Item (Node5-Sem)
       --  From_At_Mod (Flag4-Sem)
       --  Check_Address_Alignment (Flag11-Sem)
+      --  Address_Warning_Posted (Flag18-Sem)
 
       ---------------------------------------------
       -- 13.4  Enumeration representation clause --
@@ -7426,6 +7438,9 @@ package Sinfo is
    function Actual_Designated_Subtype
      (N : Node_Id) return Node_Id;    -- Node4
 
+   function Address_Warning_Posted
+     (N : Node_Id) return Boolean;    -- Flag18
+
    function Aggregate_Bounds
      (N : Node_Id) return Node_Id;    -- Node3
 
@@ -7873,6 +7888,9 @@ package Sinfo is
    function Is_Entry_Barrier_Function
      (N : Node_Id) return Boolean;    -- Flag8
 
+   function Is_Expanded_Build_In_Place_Call
+     (N : Node_Id) return Boolean;    -- Flag11
+
    function Is_Folded_In_Parser
      (N : Node_Id) return Boolean;    -- Flag4
 
@@ -8287,6 +8305,9 @@ package Sinfo is
    procedure Set_Actual_Designated_Subtype
      (N : Node_Id; Val : Node_Id);            -- Node4
 
+   procedure Set_Address_Warning_Posted
+     (N : Node_Id; Val : Boolean := True);    -- Flag18
+
    procedure Set_Aggregate_Bounds
      (N : Node_Id; Val : Node_Id);            -- Node3
 
@@ -8731,6 +8752,9 @@ package Sinfo is
    procedure Set_Is_Entry_Barrier_Function
      (N : Node_Id; Val : Boolean := True);    -- Flag8
 
+   procedure Set_Is_Expanded_Build_In_Place_Call
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
    procedure Set_Is_Folded_In_Parser
      (N : Node_Id; Val : Boolean := True);    -- Flag4
 
@@ -10677,6 +10701,7 @@ package Sinfo is
    pragma Inline (Activation_Chain_Entity);
    pragma Inline (Acts_As_Spec);
    pragma Inline (Actual_Designated_Subtype);
+   pragma Inline (Address_Warning_Posted);
    pragma Inline (Aggregate_Bounds);
    pragma Inline (Aliased_Present);
    pragma Inline (All_Others);
@@ -10826,6 +10851,7 @@ package Sinfo is
    pragma Inline (Is_Controlling_Actual);
    pragma Inline (Is_Dynamic_Coextension);
    pragma Inline (Is_Entry_Barrier_Function);
+   pragma Inline (Is_Expanded_Build_In_Place_Call);
    pragma Inline (Is_Folded_In_Parser);
    pragma Inline (Is_In_Discriminant_Check);
    pragma Inline (Is_Machine_Number);
@@ -10961,6 +10987,7 @@ package Sinfo is
    pragma Inline (Set_Activation_Chain_Entity);
    pragma Inline (Set_Acts_As_Spec);
    pragma Inline (Set_Actual_Designated_Subtype);
+   pragma Inline (Set_Address_Warning_Posted);
    pragma Inline (Set_Aggregate_Bounds);
    pragma Inline (Set_Aliased_Present);
    pragma Inline (Set_All_Others);
@@ -11108,6 +11135,7 @@ package Sinfo is
    pragma Inline (Set_Is_Controlling_Actual);
    pragma Inline (Set_Is_Dynamic_Coextension);
    pragma Inline (Set_Is_Entry_Barrier_Function);
+   pragma Inline (Set_Is_Expanded_Build_In_Place_Call);
    pragma Inline (Set_Is_Folded_In_Parser);
    pragma Inline (Set_Is_In_Discriminant_Check);
    pragma Inline (Set_Is_Machine_Number);