1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- A S P E C T S -- 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 32with Atree; use Atree; 33with Einfo; use Einfo; 34with Nlists; use Nlists; 35with Sinfo; use Sinfo; 36with Tree_IO; use Tree_IO; 37 38with GNAT.HTable; use GNAT.HTable; 39 40package body Aspects is 41 42 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id); 43 -- Same as Set_Aspect_Specifications, but does not contain the assertion 44 -- that checks that N does not already have aspect specifications. This 45 -- subprogram is supposed to be used as a part of Tree_Read. When reading 46 -- tree, first read nodes with their basic properties (as Atree.Tree_Read), 47 -- this includes reading the Has_Aspects flag for each node, then we reed 48 -- all the list tables and only after that we call Tree_Read for Aspects. 49 -- That is, when reading the tree, the list of aspects is attached to the 50 -- node that already has Has_Aspects flag set ON. 51 52 ------------------------------------------ 53 -- Hash Table for Aspect Specifications -- 54 ------------------------------------------ 55 56 type AS_Hash_Range is range 0 .. 510; 57 -- Size of hash table headers 58 59 function AS_Hash (F : Node_Id) return AS_Hash_Range; 60 -- Hash function for hash table 61 62 function AS_Hash (F : Node_Id) return AS_Hash_Range is 63 begin 64 return AS_Hash_Range (F mod 511); 65 end AS_Hash; 66 67 package Aspect_Specifications_Hash_Table is new 68 GNAT.HTable.Simple_HTable 69 (Header_Num => AS_Hash_Range, 70 Element => List_Id, 71 No_Element => No_List, 72 Key => Node_Id, 73 Hash => AS_Hash, 74 Equal => "="); 75 76 ------------------------------------- 77 -- Hash Table for Aspect Id Values -- 78 ------------------------------------- 79 80 type AI_Hash_Range is range 0 .. 112; 81 -- Size of hash table headers 82 83 function AI_Hash (F : Name_Id) return AI_Hash_Range; 84 -- Hash function for hash table 85 86 function AI_Hash (F : Name_Id) return AI_Hash_Range is 87 begin 88 return AI_Hash_Range (F mod 113); 89 end AI_Hash; 90 91 package Aspect_Id_Hash_Table is new 92 GNAT.HTable.Simple_HTable 93 (Header_Num => AI_Hash_Range, 94 Element => Aspect_Id, 95 No_Element => No_Aspect, 96 Key => Name_Id, 97 Hash => AI_Hash, 98 Equal => "="); 99 100 --------------------------- 101 -- Aspect_Specifications -- 102 --------------------------- 103 104 function Aspect_Specifications (N : Node_Id) return List_Id is 105 begin 106 if Has_Aspects (N) then 107 return Aspect_Specifications_Hash_Table.Get (N); 108 else 109 return No_List; 110 end if; 111 end Aspect_Specifications; 112 113 ------------------- 114 -- Get_Aspect_Id -- 115 ------------------- 116 117 function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is 118 begin 119 return Aspect_Id_Hash_Table.Get (Name); 120 end Get_Aspect_Id; 121 122 ----------------- 123 -- Find_Aspect -- 124 ----------------- 125 126 function Find_Aspect (Ent : Entity_Id; A : Aspect_Id) return Node_Id is 127 Ritem : Node_Id; 128 Typ : Entity_Id; 129 130 begin 131 132 -- If the aspect is an inherited one and the entity is a class-wide 133 -- type, use the aspect of the specific type. If the type is a base 134 -- aspect, examine the rep. items of the base type. 135 136 if Is_Type (Ent) then 137 if Base_Aspect (A) then 138 Typ := Base_Type (Ent); 139 else 140 Typ := Ent; 141 end if; 142 143 if Is_Class_Wide_Type (Typ) 144 and then Inherited_Aspect (A) 145 then 146 Ritem := First_Rep_Item (Etype (Typ)); 147 else 148 Ritem := First_Rep_Item (Typ); 149 end if; 150 151 else 152 Ritem := First_Rep_Item (Ent); 153 end if; 154 155 while Present (Ritem) loop 156 if Nkind (Ritem) = N_Aspect_Specification 157 and then Get_Aspect_Id (Chars (Identifier (Ritem))) = A 158 then 159 if A = Aspect_Default_Iterator then 160 return Expression (Aspect_Rep_Item (Ritem)); 161 else 162 return Expression (Ritem); 163 end if; 164 end if; 165 166 Next_Rep_Item (Ritem); 167 end loop; 168 169 return Empty; 170 end Find_Aspect; 171 172 ------------------ 173 -- Move_Aspects -- 174 ------------------ 175 176 procedure Move_Aspects (From : Node_Id; To : Node_Id) is 177 pragma Assert (not Has_Aspects (To)); 178 begin 179 if Has_Aspects (From) then 180 Set_Aspect_Specifications (To, Aspect_Specifications (From)); 181 Aspect_Specifications_Hash_Table.Remove (From); 182 Set_Has_Aspects (From, False); 183 end if; 184 end Move_Aspects; 185 186 ----------------------------------- 187 -- Permits_Aspect_Specifications -- 188 ----------------------------------- 189 190 Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean := 191 (N_Abstract_Subprogram_Declaration => True, 192 N_Component_Declaration => True, 193 N_Entry_Declaration => True, 194 N_Exception_Declaration => True, 195 N_Exception_Renaming_Declaration => True, 196 N_Expression_Function => True, 197 N_Formal_Abstract_Subprogram_Declaration => True, 198 N_Formal_Concrete_Subprogram_Declaration => True, 199 N_Formal_Object_Declaration => True, 200 N_Formal_Package_Declaration => True, 201 N_Formal_Type_Declaration => True, 202 N_Full_Type_Declaration => True, 203 N_Function_Instantiation => True, 204 N_Generic_Package_Declaration => True, 205 N_Generic_Renaming_Declaration => True, 206 N_Generic_Subprogram_Declaration => True, 207 N_Object_Declaration => True, 208 N_Object_Renaming_Declaration => True, 209 N_Package_Declaration => True, 210 N_Package_Instantiation => True, 211 N_Package_Specification => True, 212 N_Package_Renaming_Declaration => True, 213 N_Private_Extension_Declaration => True, 214 N_Private_Type_Declaration => True, 215 N_Procedure_Instantiation => True, 216 N_Protected_Body => True, 217 N_Protected_Type_Declaration => True, 218 N_Single_Protected_Declaration => True, 219 N_Single_Task_Declaration => True, 220 N_Subprogram_Body => True, 221 N_Subprogram_Declaration => True, 222 N_Subprogram_Renaming_Declaration => True, 223 N_Subtype_Declaration => True, 224 N_Task_Body => True, 225 N_Task_Type_Declaration => True, 226 others => False); 227 228 function Permits_Aspect_Specifications (N : Node_Id) return Boolean is 229 begin 230 return Has_Aspect_Specifications_Flag (Nkind (N)); 231 end Permits_Aspect_Specifications; 232 233 ----------------- 234 -- Same_Aspect -- 235 ----------------- 236 237 -- Table used for Same_Aspect, maps aspect to canonical aspect 238 239 Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id := 240 (No_Aspect => No_Aspect, 241 Aspect_Abstract_State => Aspect_Abstract_State, 242 Aspect_Ada_2005 => Aspect_Ada_2005, 243 Aspect_Ada_2012 => Aspect_Ada_2005, 244 Aspect_Address => Aspect_Address, 245 Aspect_Alignment => Aspect_Alignment, 246 Aspect_All_Calls_Remote => Aspect_All_Calls_Remote, 247 Aspect_Asynchronous => Aspect_Asynchronous, 248 Aspect_Atomic => Aspect_Atomic, 249 Aspect_Atomic_Components => Aspect_Atomic_Components, 250 Aspect_Attach_Handler => Aspect_Attach_Handler, 251 Aspect_Bit_Order => Aspect_Bit_Order, 252 Aspect_Compiler_Unit => Aspect_Compiler_Unit, 253 Aspect_Component_Size => Aspect_Component_Size, 254 Aspect_Constant_Indexing => Aspect_Constant_Indexing, 255 Aspect_Contract_Case => Aspect_Contract_Case, 256 Aspect_Contract_Cases => Aspect_Contract_Cases, 257 Aspect_Convention => Aspect_Convention, 258 Aspect_CPU => Aspect_CPU, 259 Aspect_Default_Component_Value => Aspect_Default_Component_Value, 260 Aspect_Default_Iterator => Aspect_Default_Iterator, 261 Aspect_Default_Value => Aspect_Default_Value, 262 Aspect_Dimension => Aspect_Dimension, 263 Aspect_Dimension_System => Aspect_Dimension_System, 264 Aspect_Discard_Names => Aspect_Discard_Names, 265 Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, 266 Aspect_Dynamic_Predicate => Aspect_Predicate, 267 Aspect_Elaborate_Body => Aspect_Elaborate_Body, 268 Aspect_Export => Aspect_Export, 269 Aspect_External_Name => Aspect_External_Name, 270 Aspect_External_Tag => Aspect_External_Tag, 271 Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, 272 Aspect_Global => Aspect_Global, 273 Aspect_Implicit_Dereference => Aspect_Implicit_Dereference, 274 Aspect_Import => Aspect_Import, 275 Aspect_Independent => Aspect_Independent, 276 Aspect_Independent_Components => Aspect_Independent_Components, 277 Aspect_Inline => Aspect_Inline, 278 Aspect_Inline_Always => Aspect_Inline, 279 Aspect_Input => Aspect_Input, 280 Aspect_Interrupt_Handler => Aspect_Interrupt_Handler, 281 Aspect_Interrupt_Priority => Aspect_Priority, 282 Aspect_Invariant => Aspect_Invariant, 283 Aspect_Iterator_Element => Aspect_Iterator_Element, 284 Aspect_Link_Name => Aspect_Link_Name, 285 Aspect_Lock_Free => Aspect_Lock_Free, 286 Aspect_Machine_Radix => Aspect_Machine_Radix, 287 Aspect_No_Return => Aspect_No_Return, 288 Aspect_Object_Size => Aspect_Object_Size, 289 Aspect_Output => Aspect_Output, 290 Aspect_Pack => Aspect_Pack, 291 Aspect_Persistent_BSS => Aspect_Persistent_BSS, 292 Aspect_Post => Aspect_Post, 293 Aspect_Postcondition => Aspect_Post, 294 Aspect_Pre => Aspect_Pre, 295 Aspect_Precondition => Aspect_Pre, 296 Aspect_Predicate => Aspect_Predicate, 297 Aspect_Preelaborate => Aspect_Preelaborate, 298 Aspect_Preelaborate_05 => Aspect_Preelaborate_05, 299 Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization, 300 Aspect_Priority => Aspect_Priority, 301 Aspect_Pure => Aspect_Pure, 302 Aspect_Pure_05 => Aspect_Pure_05, 303 Aspect_Pure_12 => Aspect_Pure_12, 304 Aspect_Pure_Function => Aspect_Pure_Function, 305 Aspect_Remote_Access_Type => Aspect_Remote_Access_Type, 306 Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, 307 Aspect_Remote_Types => Aspect_Remote_Types, 308 Aspect_Read => Aspect_Read, 309 Aspect_Relative_Deadline => Aspect_Relative_Deadline, 310 Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order, 311 Aspect_Shared => Aspect_Atomic, 312 Aspect_Shared_Passive => Aspect_Shared_Passive, 313 Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool, 314 Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type, 315 Aspect_Size => Aspect_Size, 316 Aspect_Small => Aspect_Small, 317 Aspect_Static_Predicate => Aspect_Predicate, 318 Aspect_Storage_Pool => Aspect_Storage_Pool, 319 Aspect_Storage_Size => Aspect_Storage_Size, 320 Aspect_Stream_Size => Aspect_Stream_Size, 321 Aspect_Suppress => Aspect_Suppress, 322 Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info, 323 Aspect_Synchronization => Aspect_Synchronization, 324 Aspect_Test_Case => Aspect_Test_Case, 325 Aspect_Type_Invariant => Aspect_Invariant, 326 Aspect_Unchecked_Union => Aspect_Unchecked_Union, 327 Aspect_Universal_Aliasing => Aspect_Universal_Aliasing, 328 Aspect_Universal_Data => Aspect_Universal_Data, 329 Aspect_Unmodified => Aspect_Unmodified, 330 Aspect_Unreferenced => Aspect_Unreferenced, 331 Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects, 332 Aspect_Unsuppress => Aspect_Unsuppress, 333 Aspect_Variable_Indexing => Aspect_Variable_Indexing, 334 Aspect_Value_Size => Aspect_Value_Size, 335 Aspect_Volatile => Aspect_Volatile, 336 Aspect_Volatile_Components => Aspect_Volatile_Components, 337 Aspect_Warnings => Aspect_Warnings, 338 Aspect_Write => Aspect_Write); 339 340 function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is 341 begin 342 return Canonical_Aspect (A1) = Canonical_Aspect (A2); 343 end Same_Aspect; 344 345 ------------------------------- 346 -- Set_Aspect_Specifications -- 347 ------------------------------- 348 349 procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is 350 begin 351 pragma Assert (Permits_Aspect_Specifications (N)); 352 pragma Assert (not Has_Aspects (N)); 353 pragma Assert (L /= No_List); 354 355 Set_Has_Aspects (N); 356 Set_Parent (L, N); 357 Aspect_Specifications_Hash_Table.Set (N, L); 358 end Set_Aspect_Specifications; 359 360 ---------------------------------------- 361 -- Set_Aspect_Specifications_No_Check -- 362 ---------------------------------------- 363 364 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is 365 begin 366 pragma Assert (Permits_Aspect_Specifications (N)); 367 pragma Assert (L /= No_List); 368 369 Set_Has_Aspects (N); 370 Set_Parent (L, N); 371 Aspect_Specifications_Hash_Table.Set (N, L); 372 end Set_Aspect_Specifications_No_Check; 373 374 --------------- 375 -- Tree_Read -- 376 --------------- 377 378 procedure Tree_Read is 379 Node : Node_Id; 380 List : List_Id; 381 begin 382 loop 383 Tree_Read_Int (Int (Node)); 384 Tree_Read_Int (Int (List)); 385 exit when List = No_List; 386 Set_Aspect_Specifications_No_Check (Node, List); 387 end loop; 388 end Tree_Read; 389 390 ---------------- 391 -- Tree_Write -- 392 ---------------- 393 394 procedure Tree_Write is 395 Node : Node_Id := Empty; 396 List : List_Id; 397 begin 398 Aspect_Specifications_Hash_Table.Get_First (Node, List); 399 loop 400 Tree_Write_Int (Int (Node)); 401 Tree_Write_Int (Int (List)); 402 exit when List = No_List; 403 Aspect_Specifications_Hash_Table.Get_Next (Node, List); 404 end loop; 405 end Tree_Write; 406 407-- Package initialization sets up Aspect Id hash table 408 409begin 410 for J in Aspect_Id loop 411 Aspect_Id_Hash_Table.Set (Aspect_Names (J), J); 412 end loop; 413end Aspects; 414