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