frontend.adb (Frontend): Code cleanup.

2009-07-29  Javier Miranda  <miranda@adacore.com>

	* frontend.adb (Frontend): Code cleanup.
	* exp_atag.ads, exp_atag.adb (Build_Get_Predefined_Prim_Op_Address):
	Rewriten as a procedure because it a new out-mode parameters to
	keep up-to-date the controlling tag node in the caller.
	(Build_Get_Prim_Op_Address): Rewriten as a procedure because it has a
	new out-mode parameter to keep up-to-date the controlling tag node in
	the caller.
	* exp_ch7.adb, sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb,
	exp_ch6.adb, sem_ch4.adb, exp_ch3.adb: Add new dependency on new
	package Sem_SCIL.
	* sem_aux.ads, sem_aux.adb (First_Non_SCIL_Node): Removed. Routine
	available in new package Sem_SCIL.
	(Next_Non_SCIL_Node): Ditto.
	* exp_disp.adb (Adjust_SCIL_Node): Removed. Routine available in new
	package Sem_SCIL.
	(Expand_Dispatching_Call): Update call to modified Exp_Atags routines
	plus complete decoration of SCIL dispatching node.
	(Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL.
	* exp_disp.ads (Adjust_SCIL_Node): Removed. Routine available in new
	package Sem_SCIL.
	(Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL.
	* exp_ch3.adb (Build_Init_Procedure): Fix comment.
	* sem_scil.ads, sem_scil.adb: New files.
	* gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Addition of sem_scil.o.
	Update dependencies.

From-SVN: r150199

gcc/ada/ChangeLog

+2009-07-29  Javier Miranda  <miranda@adacore.com>
+
+	* frontend.adb (Frontend): Code cleanup.
+	* exp_atag.ads, exp_atag.adb (Build_Get_Predefined_Prim_Op_Address):
+	Rewriten as a procedure because it a new out-mode parameters to
+	keep up-to-date the controlling tag node in the caller.
+	(Build_Get_Prim_Op_Address): Rewriten as a procedure because it has a
+	new out-mode parameter to keep up-to-date the controlling tag node in
+	the caller.
+	* exp_ch7.adb, sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb,
+	exp_ch6.adb, sem_ch4.adb, exp_ch3.adb: Add new dependency on new
+	package Sem_SCIL.
+	* sem_aux.ads, sem_aux.adb (First_Non_SCIL_Node): Removed. Routine
+	available in new package Sem_SCIL.
+	(Next_Non_SCIL_Node): Ditto.
+	* exp_disp.adb (Adjust_SCIL_Node): Removed. Routine available in new
+	package Sem_SCIL.
+	(Expand_Dispatching_Call): Update call to modified Exp_Atags routines
+	plus complete decoration of SCIL dispatching node.
+	(Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL.
+	* exp_disp.ads (Adjust_SCIL_Node): Removed. Routine available in new
+	package Sem_SCIL.
+	(Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL.
+	* exp_ch3.adb (Build_Init_Procedure): Fix comment.
+	* sem_scil.ads, sem_scil.adb: New files.
+	* gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Addition of sem_scil.o.
+	Update dependencies.
+
 2009-07-28  Robert Dewar  <dewar@adacore.com>
 
 	* adaint.h, einfo.ads, prj.adb, sem_util.adb, makeutl.ads,

gcc/ada/exp_atag.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2009, 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- --
@@ -227,12 +227,22 @@ package body Exp_Atag is
    -- Build_Get_Predefined_Prim_Op_Address --
    ------------------------------------------
 
-   function Build_Get_Predefined_Prim_Op_Address
+   procedure Build_Get_Predefined_Prim_Op_Address
      (Loc      : Source_Ptr;
-      Tag_Node : Node_Id;
-      Position : Uint) return Node_Id
+      Position : Uint;
+      Tag_Node : in out Node_Id;
+      New_Node :    out Node_Id)
    is
+      Ctrl_Tag : Node_Id;
+
    begin
+      Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);
+
+      --  Unchecked_Convert_To relocates the controlling tag node and therefore
+      --  we must update it.
+
+      Tag_Node := Expression (Ctrl_Tag);
+
       --  Build code that retrieves the address of the dispatch table
       --  containing the predefined Ada primitives:
       --
@@ -240,7 +250,7 @@ package body Exp_Atag is
       --    To_Predef_Prims_Table_Ptr
       --     (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
 
-      return
+      New_Node :=
         Make_Indexed_Component (Loc,
           Prefix =>
             Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
@@ -257,7 +267,7 @@ package body Exp_Atag is
                           Make_Identifier (Loc,
                             Chars => Name_Op_Subtract)),
                     Parameter_Associations => New_List (
-                      Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
+                      Ctrl_Tag,
                       New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
                                         Loc)))))),
           Expressions =>
@@ -337,12 +347,15 @@ package body Exp_Atag is
    -- Build_Get_Prim_Op_Address --
    -------------------------------
 
-   function Build_Get_Prim_Op_Address
+   procedure Build_Get_Prim_Op_Address
      (Loc      : Source_Ptr;
       Typ      : Entity_Id;
-      Tag_Node : Node_Id;
-      Position : Uint) return Node_Id
+      Position : Uint;
+      Tag_Node : in out Node_Id;
+      New_Node :    out Node_Id)
    is
+      New_Prefix : Node_Id;
+
    begin
       pragma Assert
         (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
@@ -351,11 +364,18 @@ package body Exp_Atag is
       --  declaration required to convert the tag into a pointer to
       --  the prims_ptr table (see Freeze_Record_Type).
 
-      return
+      New_Prefix :=
+        Unchecked_Convert_To
+          (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);
+
+      --  Unchecked_Convert_To relocates the controlling tag node and therefore
+      --  we must update it.
+
+      Tag_Node := Expression (New_Prefix);
+
+      New_Node :=
         Make_Indexed_Component (Loc,
-          Prefix =>
-            Unchecked_Convert_To
-              (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
+          Prefix      => New_Prefix,
           Expressions => New_List (Make_Integer_Literal (Loc, Position)));
    end Build_Get_Prim_Op_Address;
 
@@ -482,11 +502,15 @@ package body Exp_Atag is
       Position     : Uint;
       Address_Node : Node_Id) return Node_Id
    is
+      Ctrl_Tag : Node_Id := Tag_Node;
+      New_Node : Node_Id;
+
    begin
+      Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
+
       return
         Make_Assignment_Statement (Loc,
-          Name       => Build_Get_Prim_Op_Address
-                          (Loc, Typ, Tag_Node, Position),
+          Name       => New_Node,
           Expression => Address_Node);
    end Build_Set_Prim_Op_Address;
 

gcc/ada/exp_atag.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2009, 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- --
@@ -61,23 +61,26 @@ package Exp_Atag is
    --
    --  Generates: TSD (Tag).Access_Level
 
-   function Build_Get_Predefined_Prim_Op_Address
+   procedure Build_Get_Predefined_Prim_Op_Address
      (Loc      : Source_Ptr;
-      Tag_Node : Node_Id;
-      Position : Uint) return Node_Id;
+      Position : Uint;
+      Tag_Node : in out Node_Id;
+      New_Node :    out Node_Id);
    --  Given a pointer to a dispatch table (T) and a position in the DT, build
    --  code that gets the address of the predefined virtual function stored in
-   --  it (used for dispatching calls).
+   --  it (used for dispatching calls). Tag_Node is relocated.
    --
    --  Generates: Predefined_DT (Tag).D (Position);
 
-   function Build_Get_Prim_Op_Address
+   procedure Build_Get_Prim_Op_Address
      (Loc      : Source_Ptr;
       Typ      : Entity_Id;
-      Tag_Node : Node_Id;
-      Position : Uint) return Node_Id;
+      Position : Uint;
+      Tag_Node : in out Node_Id;
+      New_Node : out    Node_Id);
    --  Build code that retrieves the address of the virtual function stored in
    --  a given position of the dispatch table (used for dispatching calls).
+   --  Tag_Node is relocated.
    --
    --  Generates: To_Tag (Tag).D (Position);
 

gcc/ada/exp_ch3.adb

@@ -59,6 +59,7 @@ with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Mech; use Sem_Mech;
 with Sem_Res;  use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
 with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
@@ -2507,8 +2508,8 @@ package body Exp_Ch3 is
 
          if List_Length (Body_Stmts) = 1
 
-           --  We must skip SCIL nodes because they are currently implemented
-           --  as special N_Null_Statement nodes.
+           --  We must skip SCIL nodes because they may have been added to this
+           --  list by Insert_Actions.
 
            and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
            and then VM_Target = No_VM

gcc/ada/exp_ch4.adb

@@ -58,6 +58,7 @@ with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch13; use Sem_Ch13;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
 with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;

gcc/ada/exp_ch6.adb

@@ -64,6 +64,7 @@ with Sem_Disp; use Sem_Disp;
 with Sem_Dist; use Sem_Dist;
 with Sem_Mech; use Sem_Mech;
 with Sem_Res;  use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;

gcc/ada/exp_ch7.adb

@@ -54,6 +54,7 @@ with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch7;  use Sem_Ch7;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Res;  use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
 with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
 with Snames;   use Snames;

gcc/ada/exp_disp.ads

@@ -170,10 +170,6 @@ package Exp_Disp is
    --    Exp_Disp.Default_Prim_Op_Position - indirect use
    --    Exp_Disp.Set_All_DT_Position      - direct   use
 
-   procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id);
-   --  Searches for a SCIL dispatching node associated with Old_Node. If found
-   --  then update its SCIL_Related_Node field to reference New_Node.
-
    procedure Apply_Tag_Checks (Call_Node : Node_Id);
    --  Generate checks required on dispatching calls
 
@@ -219,10 +215,6 @@ package Exp_Disp is
    --  Otherwise they are set to the defining identifier and the subprogram
    --  body of the generated thunk.
 
-   function Find_SCIL_Node (Node : Node_Id) return Node_Id;
-   --  Searches for a SCIL dispatching node associated with Node. If not found
-   --  then return Empty.
-
    function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
    --  Ada 2005 (AI-251): Determines if E is a predefined primitive operation
 

gcc/ada/exp_util.adb

@@ -32,7 +32,6 @@ with Errout;   use Errout;
 with Exp_Aggr; use Exp_Aggr;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Ch7;  use Exp_Ch7;
-with Exp_Disp; use Exp_Disp;
 with Inline;   use Inline;
 with Itypes;   use Itypes;
 with Lib;      use Lib;
@@ -44,6 +43,7 @@ with Rident;   use Rident;
 with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_SCIL; use Sem_SCIL;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Type; use Sem_Type;

gcc/ada/frontend.adb

@@ -46,12 +46,13 @@ with Prep;
 with Prepcomp;
 with Restrict; use Restrict;
 with Rident;   use Rident;
-with Rtsfind;
+with Rtsfind;  use Rtsfind;
 with Sprint;
 with Scn;      use Scn;
 with Sem;      use Sem;
 with Sem_Aux;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_SCIL;
 with Sem_Elab; use Sem_Elab;
 with Sem_Prag; use Sem_Prag;
 with Sem_Warn; use Sem_Warn;
@@ -63,40 +64,6 @@ with Tbuild;   use Tbuild;
 with Types;    use Types;
 
 procedure Frontend is
-
-   --  Comment: I think SCIL processing is gettings scattered too much, this
-   --  is a good case, why should the top level frontend driver be doing stuff
-   --  at this level, seems wrong to me. I think we should introduce a new
-   --  unit Sem_SCIL, and move a lot of this SCIL stuff there. ???
-
-   function Check_SCIL_Node (N : Node_Id) return Traverse_Result;
-   --  Process a single node during the tree traversal, verifying that field
-   --  SCIL_Related_Node of SCIL dispatching call nodes reference subprogram
-   --  calls.
-
-   procedure Check_SCIL_Nodes is new Traverse_Proc (Check_SCIL_Node);
-   --  The traversal procedure itself
-
-   ---------------------
-   -- Check_SCIL_Node --
-   ---------------------
-
-   function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
-   begin
-      if Nkind (N) = N_SCIL_Dispatching_Call then
-         if not Nkind_In (SCIL_Related_Node (N), N_Function_Call,
-                                                 N_Procedure_Call_Statement)
-         then
-            pragma Assert (False);
-            raise Program_Error;
-         end if;
-
-         return Skip;
-      else
-         return OK;
-      end if;
-   end Check_SCIL_Node;
-
    Config_Pragmas : List_Id;
    --  Gather configuration pragmas
 
@@ -404,7 +371,7 @@ begin
    --  dispatching calls reference subprogram calls.
 
    if Generate_SCIL then
-      pragma Debug (Check_SCIL_Nodes (Cunit (Main_Unit)));
+      pragma Debug (Sem_SCIL.Check_SCIL_Nodes (Cunit (Main_Unit)));
       null;
    end if;
 

gcc/ada/sem_aux.adb

@@ -33,7 +33,6 @@
 with Atree;  use Atree;
 with Einfo;  use Einfo;
 with Namet;  use Namet;
-with Nlists; use Nlists;
 with Sinfo;  use Sinfo;
 with Snames; use Snames;
 with Stand;  use Stand;
@@ -236,22 +235,6 @@ package body Sem_Aux is
       return Ent;
    end First_Discriminant;
 
-   -------------------------
-   -- First_Non_SCIL_Node --
-   -------------------------
-
-   function First_Non_SCIL_Node (L : List_Id) return Node_Id is
-      N : Node_Id;
-
-   begin
-      N := First (L);
-      while Nkind (N) in N_SCIL_Node loop
-         Next (N);
-      end loop;
-
-      return N;
-   end First_Non_SCIL_Node;
-
    -------------------------------
    -- First_Stored_Discriminant --
    -------------------------------
@@ -754,22 +737,6 @@ package body Sem_Aux is
    end Nearest_Dynamic_Scope;
 
    ------------------------
-   -- Next_Non_SCIL_Node --
-   ------------------------
-
-   function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is
-      Aux_N : Node_Id;
-
-   begin
-      Aux_N := Next (N);
-      while Nkind (Aux_N) in N_SCIL_Node loop
-         Next (Aux_N);
-      end loop;
-
-      return Aux_N;
-   end Next_Non_SCIL_Node;
-
-   ------------------------
    -- Next_Tag_Component --
    ------------------------
 

gcc/ada/sem_aux.ads

@@ -138,9 +138,6 @@ package Sem_Aux is
    --  discriminants from Gigi's standpoint, i.e. those that will be stored in
    --  actual objects of the type.
 
-   function First_Non_SCIL_Node (L : List_Id) return Node_Id;
-   --  Returns the first non-SCIL node of list L
-
    function First_Subtype (Typ : Entity_Id) return Entity_Id;
    --  Applies to all types and subtypes. For types, yields the first subtype
    --  of the type. For subtypes, yields the first subtype of the base type of
@@ -188,10 +185,6 @@ package Sem_Aux is
    --  a dynamic scope, then it is returned. Otherwise the result is the same
    --  as that returned by Enclosing_Dynamic_Scope.
 
-   function Next_Non_SCIL_Node (N : Node_Id) return Node_Id;
-   --  N must be a member of a list. Returns the next non SCIL node in the list
-   --  containing N, or Empty if this is the last non SCIL node in the list.
-
    function Next_Tag_Component (Tag : Entity_Id) return Entity_Id;
    --  Tag must be an entity representing a _Tag field of a tagged record.
    --  The result returned is the next _Tag field in this record, or Empty

gcc/ada/sem_ch4.adb

@@ -28,7 +28,6 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
-with Exp_Disp; use Exp_Disp;
 with Exp_Util; use Exp_Util;
 with Fname;    use Fname;
 with Itypes;   use Itypes;
@@ -48,6 +47,7 @@ with Sem_Cat;  use Sem_Cat;
 with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_SCIL; use Sem_SCIL;
 with Sem_Disp; use Sem_Disp;
 with Sem_Dist; use Sem_Dist;
 with Sem_Eval; use Sem_Eval;

gcc/ada/sem_ch5.adb

@@ -28,7 +28,6 @@ with Checks;   use Checks;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Expander; use Expander;
-with Exp_Disp; use Exp_Disp;
 with Exp_Util; use Exp_Util;
 with Freeze;   use Freeze;
 with Lib;      use Lib;
@@ -47,6 +46,7 @@ with Sem_Disp; use Sem_Disp;
 with Sem_Elab; use Sem_Elab;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
 with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;

gcc/ada/sem_scil.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ S C I L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--             Copyright (C) 2009, 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- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license.          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains routines involved in the frontend addition and
+--  verification of SCIL nodes.
+
+with Atree; use Atree;
+with Types; use Types;
+
+package Sem_SCIL is
+
+   --  Here would be a good place to document what SCIL is all about ???
+
+   procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id);
+   --  Searches for a SCIL dispatching node associated with Old_Node. If found
+   --  then update its SCIL_Related_Node field to reference New_Node.
+
+   function Check_SCIL_Node (N : Node_Id) return Traverse_Result;
+   --  Process a single node during the tree traversal. Done to verify that
+   --  SCIL nodes decoration fulfill the requirements of the SCIL backend.
+
+   procedure Check_SCIL_Nodes is new Traverse_Proc (Check_SCIL_Node);
+   --  The traversal procedure itself
+
+   function Find_SCIL_Node (Node : Node_Id) return Node_Id;
+   --  Searches for a SCIL dispatching node associated with Node. If not found
+   --  then return Empty.
+
+   function First_Non_SCIL_Node (L : List_Id) return Node_Id;
+   --  Returns the first non-SCIL node of list L
+
+   function Next_Non_SCIL_Node (N : Node_Id) return Node_Id;
+   --  N must be a member of a list. Returns the next non SCIL node in the list
+   --  containing N, or Empty if this is the last non SCIL node in the list.
+
+end Sem_SCIL;

gcc/ada/sem_util.adb

@@ -50,6 +50,7 @@ with Sem_Ch8;  use Sem_Ch8;
 with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
 with Sem_Type; use Sem_Type;
 with Sinfo;    use Sinfo;
 with Sinput;   use Sinput;