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-2019, 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
32with Atree;         use Atree;
33with Opt;           use Opt;
34with Sinfo;         use Sinfo;
35with System.HTable; use System.HTable;
36
37package 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
205end SCIL_LL;
206