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-2023, 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;          use Atree;
  27 with Opt;            use Opt;
  28 with Sinfo;          use Sinfo;
  29 with Sinfo.Nodes;    use Sinfo.Nodes;
  30 with System.HTable;  use System.HTable;
  31
  32 package body SCIL_LL is
  33
  34    procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id);
  35    --  Copy the SCIL field from Source to Target (it is used as the argument
  36    --  for a call to Set_Reporting_Proc in package atree).
  37
  38    type Header_Num is range 1 .. 4096;
  39
  40    function Hash (N : Node_Id) return Header_Num;
  41    --  Hash function for Node_Ids
  42
  43    --------------------------
  44    -- Internal Hash Tables --
  45    --------------------------
  46
  47    package SCIL_Nodes is new Simple_HTable
  48      (Header_Num => Header_Num,
  49       Element    => Node_Id,
  50       No_Element => Empty,
  51       Key        => Node_Id,
  52       Hash       => Hash,
  53       Equal      => "=");
  54    --  This table records the value of attribute SCIL_Node of tree nodes
  55
  56    --------------------
  57    -- Copy_SCIL_Node --
  58    --------------------
  59
  60    procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is
  61    begin
  62       Set_SCIL_Node (Target, Get_SCIL_Node (Source));
  63    end Copy_SCIL_Node;
  64
  65    -------------------
  66    -- Get_SCIL_Node --
  67    -------------------
  68
  69    function Get_SCIL_Node (N : Node_Id) return Node_Id is
  70    begin
  71       if Generate_SCIL
  72         and then Present (N)
  73       then
  74          return SCIL_Nodes.Get (N);
  75       else
  76          return Empty;
  77       end if;
  78    end Get_SCIL_Node;
  79
  80    ----------
  81    -- Hash --
  82    ----------
  83
  84    function Hash (N : Node_Id) return Header_Num is
  85    begin
  86       return Header_Num (1 + N mod Node_Id (Header_Num'Last));
  87    end Hash;
  88
  89    ----------------
  90    -- Initialize --
  91    ----------------
  92
  93    procedure Initialize is
  94    begin
  95       SCIL_Nodes.Reset;
  96       Set_Reporting_Proc (Copy_SCIL_Node'Access);
  97    end Initialize;
  98
  99    -------------------
 100    -- Set_SCIL_Node --
 101    -------------------
 102
 103    procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id) is
 104    begin
 105       pragma Assert (Generate_SCIL);
 106
 107       if Present (Value) then
 108          case Nkind (Value) is
 109             when N_SCIL_Dispatch_Table_Tag_Init =>
 110                pragma Assert (Nkind (N) = N_Object_Declaration);
 111                null;
 112
 113             when N_SCIL_Dispatching_Call =>
 114                pragma Assert (Nkind (N) in N_Subprogram_Call);
 115                null;
 116
 117             when N_SCIL_Membership_Test =>
 118                pragma Assert
 119                  (Nkind (N) in N_Identifier | N_And_Then | N_Or_Else |
 120                                N_Expression_With_Actions | N_Function_Call);
 121                null;
 122
 123             when others =>
 124                pragma Assert (False);
 125                raise Program_Error;
 126          end case;
 127       end if;
 128
 129       SCIL_Nodes.Set (N, Value);
 130    end Set_SCIL_Node;
 131
 132 end SCIL_LL;