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-2018, 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 Atree;         use Atree;
  33 with Opt;           use Opt;
  34 with Sinfo;         use Sinfo;
  35 with System.HTable; use System.HTable;
  36
  37 package body SCIL_LL is
  38
  39    procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id);
  40    --  Copy the SCIL field from Source to Target (it is used as the argument
  41    --  for a call to Set_Reporting_Proc in package atree).
  42
  43    type Header_Num is range 1 .. 4096;
  44
  45    function Hash (N : Node_Id) return Header_Num;
  46    --  Hash function for Node_Ids
  47
  48    --------------------------
  49    -- Internal Hash Tables --
  50    --------------------------
  51
  52    package Contract_Only_Body_Flag is new Simple_HTable
  53      (Header_Num => Header_Num,
  54       Element    => Boolean,
  55       No_Element => False,
  56       Key        => Node_Id,
  57       Hash       => Hash,
  58       Equal      => "=");
  59    --  This table records the value of flag Is_Contract_Only_Flag of tree nodes
  60
  61    package Contract_Only_Body_Nodes is new Simple_HTable
  62      (Header_Num => Header_Num,
  63       Element    => Node_Id,
  64       No_Element => Empty,
  65       Key        => Node_Id,
  66       Hash       => Hash,
  67       Equal      => "=");
  68    --  This table records the value of attribute Contract_Only_Body of tree
  69    --  nodes.
  70
  71    package SCIL_Nodes is new Simple_HTable
  72      (Header_Num => Header_Num,
  73       Element    => Node_Id,
  74       No_Element => Empty,
  75       Key        => Node_Id,
  76       Hash       => Hash,
  77       Equal      => "=");
  78    --  This table records the value of attribute SCIL_Node of tree nodes
  79
  80    --------------------
  81    -- Copy_SCIL_Node --
  82    --------------------
  83
  84    procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is
  85    begin
  86       Set_SCIL_Node (Target, Get_SCIL_Node (Source));
  87    end Copy_SCIL_Node;
  88
  89    ----------------------------
  90    -- Get_Contract_Only_Body --
  91    ----------------------------
  92
  93    function Get_Contract_Only_Body (N : Node_Id) return Node_Id is
  94    begin
  95       if CodePeer_Mode
  96         and then Present (N)
  97       then
  98          return Contract_Only_Body_Nodes.Get (N);
  99       else
 100          return Empty;
 101       end if;
 102    end Get_Contract_Only_Body;
 103
 104    -------------------
 105    -- Get_SCIL_Node --
 106    -------------------
 107
 108    function Get_SCIL_Node (N : Node_Id) return Node_Id is
 109    begin
 110       if Generate_SCIL
 111         and then Present (N)
 112       then
 113          return SCIL_Nodes.Get (N);
 114       else
 115          return Empty;
 116       end if;
 117    end Get_SCIL_Node;
 118
 119    ----------
 120    -- Hash --
 121    ----------
 122
 123    function Hash (N : Node_Id) return Header_Num is
 124    begin
 125       return Header_Num (1 + N mod Node_Id (Header_Num'Last));
 126    end Hash;
 127
 128    ----------------
 129    -- Initialize --
 130    ----------------
 131
 132    procedure Initialize is
 133    begin
 134       SCIL_Nodes.Reset;
 135       Contract_Only_Body_Nodes.Reset;
 136       Contract_Only_Body_Flag.Reset;
 137       Set_Reporting_Proc (Copy_SCIL_Node'Access);
 138    end Initialize;
 139
 140    ---------------------------
 141    -- Is_Contract_Only_Body --
 142    ---------------------------
 143
 144    function Is_Contract_Only_Body (E : Entity_Id) return Boolean is
 145    begin
 146       return Contract_Only_Body_Flag.Get (E);
 147    end Is_Contract_Only_Body;
 148
 149    ----------------------------
 150    -- Set_Contract_Only_Body --
 151    ----------------------------
 152
 153    procedure Set_Contract_Only_Body (N : Node_Id; Value : Node_Id) is
 154    begin
 155       pragma Assert (CodePeer_Mode
 156         and then Present (N)
 157         and then Is_Contract_Only_Body (Value));
 158
 159       Contract_Only_Body_Nodes.Set (N, Value);
 160    end Set_Contract_Only_Body;
 161
 162    -------------------------------
 163    -- Set_Is_Contract_Only_Body --
 164    -------------------------------
 165
 166    procedure Set_Is_Contract_Only_Body (E : Entity_Id) is
 167    begin
 168       Contract_Only_Body_Flag.Set (E, True);
 169    end Set_Is_Contract_Only_Body;
 170
 171    -------------------
 172    -- Set_SCIL_Node --
 173    -------------------
 174
 175    procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id) is
 176    begin
 177       pragma Assert (Generate_SCIL);
 178
 179       if Present (Value) then
 180          case Nkind (Value) is
 181             when N_SCIL_Dispatch_Table_Tag_Init =>
 182                pragma Assert (Nkind (N) = N_Object_Declaration);
 183                null;
 184
 185             when N_SCIL_Dispatching_Call =>
 186                pragma Assert (Nkind (N) in N_Subprogram_Call);
 187                null;
 188
 189             when N_SCIL_Membership_Test =>
 190                pragma Assert (Nkind_In (N, N_Identifier,
 191                                            N_And_Then,
 192                                            N_Or_Else,
 193                                            N_Expression_With_Actions));
 194                null;
 195
 196             when others =>
 197                pragma Assert (False);
 198                raise Program_Error;
 199          end case;
 200       end if;
 201
 202       SCIL_Nodes.Set (N, Value);
 203    end Set_SCIL_Node;
 204
 205 end SCIL_LL;