gcc/ada/scil_ll.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S C I L _ L L                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2012, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Alloc; use Alloc;
  33 with Atree; use Atree;
  34 with Opt;   use Opt;
  35 with Sinfo; use Sinfo;
  36 with Table;
  37
  38 package body SCIL_LL is
  39
  40    procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id);
  41    --  Copy the SCIL field from Source to Target (it is used as the argument
  42    --  for a call to Set_Reporting_Proc in package atree).
  43
  44    function SCIL_Nodes_Table_Size return Pos;
  45    --  Used to initialize the table of SCIL nodes because we do not want
  46    --  to consume memory for this table if it is not required.
  47
  48    ----------------------------
  49    --  SCIL_Nodes_Table_Size --
  50    ----------------------------
  51
  52    function SCIL_Nodes_Table_Size return Pos is
  53    begin
  54       if Generate_SCIL then
  55          return Alloc.Orig_Nodes_Initial;
  56       else
  57          return 1;
  58       end if;
  59    end SCIL_Nodes_Table_Size;
  60
  61    package SCIL_Nodes is new Table.Table (
  62       Table_Component_Type => Node_Id,
  63       Table_Index_Type     => Node_Id'Base,
  64       Table_Low_Bound      => First_Node_Id,
  65       Table_Initial        => SCIL_Nodes_Table_Size,
  66       Table_Increment      => Alloc.Orig_Nodes_Increment,
  67       Table_Name           => "SCIL_Nodes");
  68    --  This table records the value of attribute SCIL_Node of all the
  69    --  tree nodes.
  70
  71    --------------------
  72    -- Copy_SCIL_Node --
  73    --------------------
  74
  75    procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is
  76    begin
  77       Set_SCIL_Node (Target, Get_SCIL_Node (Source));
  78    end Copy_SCIL_Node;
  79
  80    ----------------
  81    -- Initialize --
  82    ----------------
  83
  84    procedure Initialize is
  85    begin
  86       SCIL_Nodes.Init;
  87       Set_Reporting_Proc (Copy_SCIL_Node'Access);
  88    end Initialize;
  89
  90    -------------------
  91    -- Get_SCIL_Node --
  92    -------------------
  93
  94    function Get_SCIL_Node (N : Node_Id) return Node_Id is
  95    begin
  96       if Generate_SCIL
  97         and then Present (N)
  98       then
  99          return SCIL_Nodes.Table (N);
 100       else
 101          return Empty;
 102       end if;
 103    end Get_SCIL_Node;
 104
 105    -------------------
 106    -- Set_SCIL_Node --
 107    -------------------
 108
 109    procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id) is
 110    begin
 111       pragma Assert (Generate_SCIL);
 112
 113       if Present (Value) then
 114          case Nkind (Value) is
 115             when N_SCIL_Dispatch_Table_Tag_Init =>
 116                pragma Assert (Nkind (N) = N_Object_Declaration);
 117                null;
 118
 119             when N_SCIL_Dispatching_Call =>
 120                pragma Assert (Nkind (N) in N_Subprogram_Call);
 121                null;
 122
 123             when N_SCIL_Membership_Test =>
 124                pragma Assert (Nkind_In (N, N_Identifier,
 125                                            N_And_Then,
 126                                            N_Or_Else,
 127                                            N_Expression_With_Actions));
 128                null;
 129
 130             when others =>
 131                pragma Assert (False);
 132                raise Program_Error;
 133          end case;
 134       end if;
 135
 136       if Atree.Last_Node_Id > SCIL_Nodes.Last then
 137          SCIL_Nodes.Set_Last (Atree.Last_Node_Id);
 138       end if;
 139
 140       SCIL_Nodes.Set_Item (N, Value);
 141    end Set_SCIL_Node;
 142
 143 end SCIL_LL;