exp_ch7.ads, [...] (Expand_Cleanup_Actions): Set Sloc of inserted cleanup code…

exp_ch7.ads, [...] (Expand_Cleanup_Actions): Set Sloc of inserted cleanup code appropriately for GDB use.

2007-04-20  Ed Schonberg  <schonberg@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* exp_ch7.ads, exp_ch7.adb (Expand_Cleanup_Actions): Set Sloc of
	inserted cleanup code appropriately for GDB use.
	(Make_Deep_Proc): Use Make_Handler_For_Ctrl_Operation to create
	exception handler for Deep_Adjust or Deep_Finalize.
	(Make_Handler_For_Ctrl_Operation): New subprogram. When runtime entity
	Raise_From_Controlled_Operation is available, use a call to that
	subprogram instead of a plain "raise Program_Error" node to raise
	Program_Error if an exception is propagated from an Adjust or Finalize
	operation.
	(Insert_Actions_In_Scope_Around): If the statement to be wrapped
	appears in the optional statement list of a triggering alternative, the
	scope actions can be inserted directly there, and not in the list that
	includes the asynchronous select itself.

From-SVN: r125400

gcc/ada/exp_ch7.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -40,7 +40,6 @@ with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Freeze;   use Freeze;
 with Lib;      use Lib;
-with Hostparm; use Hostparm;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
@@ -58,6 +57,7 @@ with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
 with Snames;   use Snames;
 with Stand;    use Stand;
+with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 
@@ -90,27 +90,33 @@ package body Exp_Ch7 is
    --      declaration and the secondary stack deallocation is done in the
    --      proper enclosing scope (see Wrap_Transient_Declaration for details)
 
-   --  Note about function returning tagged types: It has been decided to
-   --  always allocate their result in the secondary stack while it is not
+   --  Note about functions returning tagged types: It has been decided to
+   --  always allocate their result in the secondary stack, even though is not
    --  absolutely mandatory when the tagged type is constrained because the
    --  caller knows the size of the returned object and thus could allocate the
-   --  result in the primary stack. But, allocating them always in the
-   --  secondary stack simplifies many implementation hassles:
+   --  result in the primary stack. An exception to this is when the function
+   --  builds its result in place, as is done for functions with inherently
+   --  limited result types for Ada 2005. In that case, certain callers may
+   --  pass the address of a constrained object as the target object for the
+   --  function result.
 
-   --    - If it is dispatching function call, the computation of the size of
+   --  By allocating tagged results in the secondary stack a number of
+   --  implementation difficulties are avoided:
+
+   --    - If it is a dispatching function call, the computation of the size of
    --      the result is possible but complex from the outside.
 
    --    - If the returned type is controlled, the assignment of the returned
    --      value to the anonymous object involves an Adjust, and we have no
-   --      easy way to access the anonymous object created by the back-end
+   --      easy way to access the anonymous object created by the back end.
 
    --    - If the returned type is class-wide, this is an unconstrained type
-   --      anyway
+   --      anyway.
 
-   --  Furthermore, the little loss in efficiency which is the result of this
-   --  decision is not such a big deal because function returning tagged types
-   --  are not very much used in real life as opposed to functions returning
-   --  access to a tagged type
+   --  Furthermore, the small loss in efficiency which is the result of this
+   --  decision is not such a big deal because functions returning tagged types
+   --  are not as common in practice compared to functions returning access to
+   --  a tagged type.
 
    --------------------------------------------------
    -- Transient Blocks and Finalization Management --
@@ -245,8 +251,8 @@ package body Exp_Ch7 is
    --  controlled components (Has_Controlled_Component flag set). In the first
    --  case the procedures to call are the user-defined primitive operations
    --  Initialize/Adjust/Finalize. In the second case, GNAT generates
-   --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge of
-   --  calling the former procedures on the controlled components.
+   --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
+   --  of calling the former procedures on the controlled components.
 
    --  For records with Has_Controlled_Component set, a hidden "controller"
    --  component is inserted. This controller component contains its own
@@ -255,9 +261,9 @@ package body Exp_Ch7 is
    --  technique facilitates the management of objects whose number of
    --  controlled components changes during execution. This controller
    --  component is itself controlled and is attached to the upper-level
-   --  finalization chain. Its adjust primitive is in charge of calling
-   --  adjust on the components and adusting the finalization pointer to
-   --  match their new location (see a-finali.adb).
+   --  finalization chain. Its adjust primitive is in charge of calling adjust
+   --  on the components and adusting the finalization pointer to match their
+   --  new location (see a-finali.adb).
 
    --  It is not possible to use a similar technique for arrays that have
    --  Has_Controlled_Component set. In this case, deep procedures are
@@ -265,11 +271,11 @@ package body Exp_Ch7 is
    --  detachment on the finalization list for all component.
 
    --  Initialize calls: they are generated for declarations or dynamic
-   --  allocations of Controlled objects with no initial value. They are
-   --  always followed by an attachment to the current Finalization
-   --  Chain. For the dynamic allocation case this the chain attached to
-   --  the scope of the access type definition otherwise, this is the chain
-   --  of the current scope.
+   --  allocations of Controlled objects with no initial value. They are always
+   --  followed by an attachment to the current Finalization Chain. For the
+   --  dynamic allocation case this the chain attached to the scope of the
+   --  access type definition otherwise, this is the chain of the current
+   --  scope.
 
    --  Adjust Calls: They are generated on 2 occasions: (1) for
    --  declarations or dynamic allocations of Controlled objects with an
@@ -280,21 +286,26 @@ package body Exp_Ch7 is
    --  Finalization Calls: They are generated on (1) scope exit, (2)
    --  assignments, (3) unchecked deallocations. In case (3) they have to
    --  be detached from the final chain, in case (2) they must not and in
-   --  case (1) this is not important since we are exiting the scope
-   --  anyway.
+   --  case (1) this is not important since we are exiting the scope anyway.
 
    --  Other details:
-   --    - Type extensions will have a new record controller at each derivation
-   --      level containing controlled components.
-   --    - For types that are both Is_Controlled and Has_Controlled_Components,
+
+   --    Type extensions will have a new record controller at each derivation
+   --    level containing controlled components. The record controller for
+   --    the parent/ancestor is attached to the finalization list of the
+   --    extension's record controller (i.e. the parent is like a component
+   --    of the extension).
+
+   --    For types that are both Is_Controlled and Has_Controlled_Components,
    --    the record controller and the object itself are handled separately.
    --    It could seem simpler to attach the object at the end of its record
    --    controller but this would not tackle view conversions properly.
-   --    - A classwide type can always potentially have controlled components
+
+   --    A classwide type can always potentially have controlled components
    --    but the record controller of the corresponding actual type may not
    --    be known at compile time so the dispatch table contains a special
    --    field that allows to compute the offset of the record controller
-   --      dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset
+   --    dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
 
    --  Here is a simple example of the expansion of a controlled block :
 
@@ -1031,6 +1042,12 @@ package body Exp_Ch7 is
       Wrap_Node : Node_Id;
 
    begin
+      --  Nothing to do for virtual machines where memory is GCed
+
+      if VM_Target /= No_VM then
+         return;
+      end if;
+
       --  Do not create a transient scope if we are already inside one
 
       for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
@@ -1066,7 +1083,7 @@ package body Exp_Ch7 is
          null;
 
       else
-         New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
+         Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
          Set_Scope_Is_Transient;
 
          if Sec_Stack then
@@ -1089,13 +1106,10 @@ package body Exp_Ch7 is
    ----------------------------
 
    procedure Expand_Cleanup_Actions (N : Node_Id) is
-      Loc                  :  Source_Ptr;
-      S                    : constant Entity_Id  :=
-                               Current_Scope;
-      Flist                : constant Entity_Id  :=
-                               Finalization_Chain_Entity (S);
-      Is_Task              : constant Boolean    :=
-                               (Nkind (Original_Node (N)) = N_Task_Body);
+      S       : constant Entity_Id  := Current_Scope;
+      Flist   : constant Entity_Id := Finalization_Chain_Entity (S);
+      Is_Task : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body;
+
       Is_Master            : constant Boolean :=
                                Nkind (N) /= N_Entry_Body
                                  and then Is_Task_Master (N);
@@ -1110,6 +1124,7 @@ package body Exp_Ch7 is
                                  and then Is_Asynchronous_Call_Block (N);
 
       Clean     : Entity_Id;
+      Loc       : Source_Ptr;
       Mark      : Entity_Id := Empty;
       New_Decls : constant List_Id := New_List;
       Blok      : Node_Id;
@@ -1120,21 +1135,19 @@ package body Exp_Ch7 is
       Old_Poll  : Boolean;
 
    begin
-
-      --  Compute a location that is not directly in the user code in
-      --  order to avoid to generate confusing debug info. A good
-      --  approximation is the name of the outer user-defined scope
-
-      declare
-         S1 : Entity_Id := S;
-
-      begin
-         while not Comes_From_Source (S1) and then S1 /= Standard_Standard loop
-            S1 := Scope (S1);
-         end loop;
-
-         Loc := Sloc (S1);
-      end;
+      --  If we are generating expanded code for debugging purposes, use
+      --  the Sloc of the point of insertion for the cleanup code. The Sloc
+      --  will be updated subsequently to reference the proper line in the
+      --  .dg file.  If we are not debugging generated code, use instead
+      --  No_Location, so that no debug information is generated for the
+      --  cleanup code. This makes the behavior of the NEXT command in GDB
+      --  monotonic, and makes the placement of breakpoints more accurate.
+
+      if Debug_Generated_Code then
+         Loc := Sloc (S);
+      else
+         Loc := No_Location;
+      end if;
 
       --  There are cleanup actions only if the secondary stack needs
       --  releasing or some finalizations are needed or in the context
@@ -1194,12 +1207,12 @@ package body Exp_Ch7 is
       --  If secondary stack is in use, expand:
       --    _Mxx : constant Mark_Id := SS_Mark;
 
-      --  Suppress calls to SS_Mark and SS_Release if Java_VM,
-      --  since we never use the secondary stack on the JVM.
+      --  Suppress calls to SS_Mark and SS_Release if VM_Target,
+      --  since we never use the secondary stack on the VM.
 
       if Uses_Sec_Stack (Current_Scope)
         and then not Sec_Stack_Needed_For_Return (Current_Scope)
-        and then not Java_VM
+        and then VM_Target = No_VM
       then
          Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
          Append_To (New_Decls,
@@ -1565,7 +1578,7 @@ package body Exp_Ch7 is
       --  This is done only for non-generic packages
 
       if Ekind (Ent) = E_Package then
-         New_Scope (Corresponding_Spec (N));
+         Push_Scope (Corresponding_Spec (N));
          Build_Task_Activation_Call (N);
          Pop_Scope;
       end if;
@@ -1629,8 +1642,7 @@ package body Exp_Ch7 is
       --  have a specific separate compilation unit for that).
 
       if No_Body then
-
-         New_Scope (Defining_Entity (N));
+         Push_Scope (Defining_Entity (N));
 
          if Has_RACW (Defining_Entity (N)) then
 
@@ -2016,12 +2028,17 @@ package body Exp_Ch7 is
       Target : Node_Id;
 
    begin
-      --  If the node to be wrapped is the triggering alternative of an
+      --  If the node to be wrapped is the triggering statement of an
       --  asynchronous select, it is not part of a statement list. The
       --  actions must be inserted before the Select itself, which is
-      --  part of some list of statements.
+      --  part of some list of statements. Note that the triggering
+      --  alternative includes the triggering statement and an optional
+      --  statement list. If the node to be wrapped is part of that list,
+      --  the normal insertion applies.
 
-      if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative then
+      if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative
+        and then not Is_List_Member (Node_To_Be_Wrapped)
+      then
          Target := Parent (Parent (Node_To_Be_Wrapped));
       else
          Target := N;
@@ -2661,12 +2678,7 @@ package body Exp_Ch7 is
           Parameter_Type      => New_Reference_To (Type_B, Loc)));
 
       if Prim = Finalize_Case or else Prim = Adjust_Case then
-         Handler := New_List (
-           Make_Implicit_Exception_Handler (Loc,
-             Exception_Choices => New_List (Make_Others_Choice (Loc)),
-             Statements        => New_List (
-               Make_Raise_Program_Error (Loc,
-                 Reason => PE_Finalize_Raised_Exception))));
+         Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc));
       end if;
 
       Proc_Name :=
@@ -2932,6 +2944,61 @@ package body Exp_Ch7 is
       return Res;
    end Make_Final_Call;
 
+   -------------------------------------
+   -- Make_Handler_For_Ctrl_Operation --
+   -------------------------------------
+
+   --  Generate:
+
+   --    when E : others =>
+   --      Raise_From_Controlled_Operation (X => E);
+
+   --  or:
+
+   --    when others =>
+   --      raise Program_Error [finalize raised exception];
+
+   --  depending on whether Raise_From_Controlled_Operation is available
+
+   function Make_Handler_For_Ctrl_Operation
+     (Loc : Source_Ptr) return Node_Id
+   is
+      E_Occ : Entity_Id;
+      --  Choice parameter (for the first case above)
+
+      Raise_Node : Node_Id;
+      --  Procedure call or raise statement
+
+   begin
+      if RTE_Available (RE_Raise_From_Controlled_Operation) then
+
+         --  Standard runtime: add choice parameter E, and pass it to
+         --  Raise_From_Controlled_Operation so that the original exception
+         --  name and message can be recorded in the exception message for
+         --  Program_Error.
+
+         E_Occ := Make_Defining_Identifier (Loc, Name_E);
+         Raise_Node := Make_Procedure_Call_Statement (Loc,
+                         Name =>
+                           New_Occurrence_Of (
+                             RTE (RE_Raise_From_Controlled_Operation), Loc),
+                         Parameter_Associations => New_List (
+                           New_Occurrence_Of (E_Occ, Loc)));
+
+      else
+         --  Restricted runtime: exception messages are not supported
+
+         E_Occ := Empty;
+         Raise_Node := Make_Raise_Program_Error (Loc,
+                         Reason => PE_Finalize_Raised_Exception);
+      end if;
+
+      return Make_Implicit_Exception_Handler (Loc,
+               Exception_Choices => New_List (Make_Others_Choice (Loc)),
+               Choice_Parameter  => E_Occ,
+               Statements        => New_List (Raise_Node));
+   end Make_Handler_For_Ctrl_Operation;
+
    --------------------
    -- Make_Init_Call --
    --------------------
@@ -3069,7 +3136,8 @@ package body Exp_Ch7 is
    begin
       --  Case where only secondary stack use is involved
 
-      if Uses_Sec_Stack (Current_Scope)
+      if VM_Target = No_VM
+        and then Uses_Sec_Stack (Current_Scope)
         and then No (Flist)
         and then Nkind (Action) /= N_Return_Statement
         and then Nkind (Par) /= N_Exception_Handler
@@ -3136,7 +3204,6 @@ package body Exp_Ch7 is
 
       declare
          Last_Inserted : Node_Id := Prev (Action);
-
       begin
          if Present (Last_Inserted) then
             Freeze_All (First_Entity (Current_Scope), Last_Inserted);
@@ -3340,7 +3407,7 @@ package body Exp_Ch7 is
       --  released upon its exit unless this is a function that returns on
       --  the sec stack in which case this will be done by the caller.
 
-      if Uses_SS then
+      if VM_Target = No_VM and then Uses_SS then
          S := Enclosing_Dynamic_Scope (S);
 
          if Ekind (S) = E_Function
@@ -3428,7 +3495,7 @@ package body Exp_Ch7 is
    --       end _Clean;
 
    --    begin
-   --       <Instr uction>;
+   --       <Instruction>;
    --    at end
    --       _Clean;
    --    end;

gcc/ada/exp_ch7.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -24,6 +24,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Namet; use Namet;
 with Types; use Types;
 
 package Exp_Ch7 is
@@ -163,6 +164,10 @@ package Exp_Ch7 is
    --  say attach the result of the call to the current finalization list,
    --  which is the one of the transient scope created for such constructs.
 
+   function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id;
+   --  Generate an implicit exception handler with an 'others' choice,
+   --  converting any occurrence to a raise of Program_Error.
+
    --------------------------------------------
    -- Task and Protected Object finalization --
    --------------------------------------------