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-2020, 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 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Nlists; use Nlists; 29with Sinfo; use Sinfo; 30 31with GNAT.HTable; 32 33package body Aspects is 34 35 -- The following array indicates aspects that a subtype inherits from its 36 -- base type. True means that the subtype inherits the aspect from its base 37 -- type. False means it is not inherited. 38 39 Base_Aspect : constant array (Aspect_Id) of Boolean := 40 (Aspect_Atomic => True, 41 Aspect_Atomic_Components => True, 42 Aspect_Constant_Indexing => True, 43 Aspect_Default_Iterator => True, 44 Aspect_Discard_Names => True, 45 Aspect_Independent_Components => True, 46 Aspect_Iterator_Element => True, 47 Aspect_Stable_Properties => True, 48 Aspect_Type_Invariant => True, 49 Aspect_Unchecked_Union => True, 50 Aspect_Variable_Indexing => True, 51 Aspect_Volatile => True, 52 Aspect_Volatile_Full_Access => True, 53 others => False); 54 55 -- The following array indicates type aspects that are inherited and apply 56 -- to the class-wide type as well. 57 58 Inherited_Aspect : constant array (Aspect_Id) of Boolean := 59 (Aspect_Constant_Indexing => True, 60 Aspect_Default_Iterator => True, 61 Aspect_Implicit_Dereference => True, 62 Aspect_Iterator_Element => True, 63 Aspect_Remote_Types => True, 64 Aspect_Variable_Indexing => True, 65 others => False); 66 67 ------------------------------------------ 68 -- Hash Table for Aspect Specifications -- 69 ------------------------------------------ 70 71 type AS_Hash_Range is range 0 .. 510; 72 -- Size of hash table headers 73 74 function AS_Hash (F : Node_Id) return AS_Hash_Range; 75 -- Hash function for hash table 76 77 function AS_Hash (F : Node_Id) return AS_Hash_Range is 78 begin 79 return AS_Hash_Range (F mod 511); 80 end AS_Hash; 81 82 package Aspect_Specifications_Hash_Table is new 83 GNAT.HTable.Simple_HTable 84 (Header_Num => AS_Hash_Range, 85 Element => List_Id, 86 No_Element => No_List, 87 Key => Node_Id, 88 Hash => AS_Hash, 89 Equal => "="); 90 91 ------------------------------------- 92 -- Hash Table for Aspect Id Values -- 93 ------------------------------------- 94 95 type AI_Hash_Range is range 0 .. 112; 96 -- Size of hash table headers 97 98 function AI_Hash (F : Name_Id) return AI_Hash_Range; 99 -- Hash function for hash table 100 101 function AI_Hash (F : Name_Id) return AI_Hash_Range is 102 begin 103 return AI_Hash_Range (F mod 113); 104 end AI_Hash; 105 106 package Aspect_Id_Hash_Table is new 107 GNAT.HTable.Simple_HTable 108 (Header_Num => AI_Hash_Range, 109 Element => Aspect_Id, 110 No_Element => No_Aspect, 111 Key => Name_Id, 112 Hash => AI_Hash, 113 Equal => "="); 114 115 --------------------------- 116 -- Aspect_Specifications -- 117 --------------------------- 118 119 function Aspect_Specifications (N : Node_Id) return List_Id is 120 begin 121 if Has_Aspects (N) then 122 return Aspect_Specifications_Hash_Table.Get (N); 123 else 124 return No_List; 125 end if; 126 end Aspect_Specifications; 127 128 -------------------------------- 129 -- Aspects_On_Body_Or_Stub_OK -- 130 -------------------------------- 131 132 function Aspects_On_Body_Or_Stub_OK (N : Node_Id) return Boolean is 133 Aspect : Node_Id; 134 Aspects : List_Id; 135 136 begin 137 -- The routine should be invoked on a body [stub] with aspects 138 139 pragma Assert (Has_Aspects (N)); 140 pragma Assert 141 (Nkind (N) in N_Body_Stub | N_Entry_Body | N_Package_Body | 142 N_Protected_Body | N_Subprogram_Body | N_Task_Body); 143 144 -- Look through all aspects and see whether they can be applied to a 145 -- body [stub]. 146 147 Aspects := Aspect_Specifications (N); 148 Aspect := First (Aspects); 149 while Present (Aspect) loop 150 if not Aspect_On_Body_Or_Stub_OK (Get_Aspect_Id (Aspect)) then 151 return False; 152 end if; 153 154 Next (Aspect); 155 end loop; 156 157 return True; 158 end Aspects_On_Body_Or_Stub_OK; 159 160 ---------------------- 161 -- Exchange_Aspects -- 162 ---------------------- 163 164 procedure Exchange_Aspects (N1 : Node_Id; N2 : Node_Id) is 165 begin 166 pragma Assert 167 (Permits_Aspect_Specifications (N1) 168 and then Permits_Aspect_Specifications (N2)); 169 170 -- Perform the exchange only when both nodes have lists to be swapped 171 172 if Has_Aspects (N1) and then Has_Aspects (N2) then 173 declare 174 L1 : constant List_Id := Aspect_Specifications (N1); 175 L2 : constant List_Id := Aspect_Specifications (N2); 176 begin 177 Set_Parent (L1, N2); 178 Set_Parent (L2, N1); 179 Aspect_Specifications_Hash_Table.Set (N1, L2); 180 Aspect_Specifications_Hash_Table.Set (N2, L1); 181 end; 182 end if; 183 end Exchange_Aspects; 184 185 ----------------- 186 -- Find_Aspect -- 187 ----------------- 188 189 function Find_Aspect 190 (Id : Entity_Id; 191 A : Aspect_Id; 192 Class_Present : Boolean := False) return Node_Id 193 is 194 Decl : Node_Id; 195 Item : Node_Id; 196 Owner : Entity_Id; 197 Spec : Node_Id; 198 199 begin 200 Owner := Id; 201 202 -- Handle various cases of base or inherited aspects for types 203 204 if Is_Type (Id) then 205 if Base_Aspect (A) then 206 Owner := Base_Type (Owner); 207 end if; 208 209 if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then 210 Owner := Root_Type (Owner); 211 end if; 212 213 if Is_Private_Type (Owner) 214 and then Present (Full_View (Owner)) 215 and then not Operational_Aspect (A) 216 then 217 Owner := Full_View (Owner); 218 end if; 219 end if; 220 221 -- Search the representation items for the desired aspect 222 223 Item := First_Rep_Item (Owner); 224 while Present (Item) loop 225 if Nkind (Item) = N_Aspect_Specification 226 and then Get_Aspect_Id (Item) = A 227 and then Class_Present = Sinfo.Class_Present (Item) 228 then 229 return Item; 230 end if; 231 232 Next_Rep_Item (Item); 233 end loop; 234 235 -- Note that not all aspects are added to the chain of representation 236 -- items. In such cases, search the list of aspect specifications. First 237 -- find the declaration node where the aspects reside. This is usually 238 -- the parent or the parent of the parent. 239 240 Decl := Parent (Owner); 241 if not Permits_Aspect_Specifications (Decl) then 242 Decl := Parent (Decl); 243 end if; 244 245 -- Search the list of aspect specifications for the desired aspect 246 247 if Permits_Aspect_Specifications (Decl) then 248 Spec := First (Aspect_Specifications (Decl)); 249 while Present (Spec) loop 250 if Get_Aspect_Id (Spec) = A 251 and then Class_Present = Sinfo.Class_Present (Spec) 252 then 253 return Spec; 254 end if; 255 256 Next (Spec); 257 end loop; 258 end if; 259 260 -- The entity does not carry any aspects or the desired aspect was not 261 -- found. 262 263 return Empty; 264 end Find_Aspect; 265 266 -------------------------- 267 -- Find_Value_Of_Aspect -- 268 -------------------------- 269 270 function Find_Value_Of_Aspect 271 (Id : Entity_Id; 272 A : Aspect_Id; 273 Class_Present : Boolean := False) return Node_Id 274 is 275 Spec : constant Node_Id := Find_Aspect (Id, A, 276 Class_Present => Class_Present); 277 278 begin 279 if Present (Spec) then 280 if A = Aspect_Default_Iterator then 281 return Expression (Aspect_Rep_Item (Spec)); 282 else 283 return Expression (Spec); 284 end if; 285 end if; 286 287 return Empty; 288 end Find_Value_Of_Aspect; 289 290 ------------------- 291 -- Get_Aspect_Id -- 292 ------------------- 293 294 function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is 295 begin 296 return Aspect_Id_Hash_Table.Get (Name); 297 end Get_Aspect_Id; 298 299 function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is 300 begin 301 pragma Assert (Nkind (Aspect) = N_Aspect_Specification); 302 return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect))); 303 end Get_Aspect_Id; 304 305 ---------------- 306 -- Has_Aspect -- 307 ---------------- 308 309 function Has_Aspect 310 (Id : Entity_Id; 311 A : Aspect_Id; 312 Class_Present : Boolean := False) return Boolean 313 is 314 begin 315 return Present (Find_Aspect (Id, A, Class_Present => Class_Present)); 316 end Has_Aspect; 317 318 ------------------ 319 -- Move_Aspects -- 320 ------------------ 321 322 procedure Move_Aspects (From : Node_Id; To : Node_Id) is 323 pragma Assert (not Has_Aspects (To)); 324 begin 325 if Has_Aspects (From) then 326 Set_Aspect_Specifications (To, Aspect_Specifications (From)); 327 Aspect_Specifications_Hash_Table.Remove (From); 328 Set_Has_Aspects (From, False); 329 end if; 330 end Move_Aspects; 331 332 --------------------------- 333 -- Move_Or_Merge_Aspects -- 334 --------------------------- 335 336 procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is 337 procedure Relocate_Aspect (Asp : Node_Id); 338 -- Move aspect specification Asp to the aspect specifications of node To 339 340 --------------------- 341 -- Relocate_Aspect -- 342 --------------------- 343 344 procedure Relocate_Aspect (Asp : Node_Id) is 345 Asps : List_Id; 346 347 begin 348 if Has_Aspects (To) then 349 Asps := Aspect_Specifications (To); 350 351 -- Create a new aspect specification list for node To 352 353 else 354 Asps := New_List; 355 Set_Aspect_Specifications (To, Asps); 356 Set_Has_Aspects (To); 357 end if; 358 359 -- Remove the aspect from its original owner and relocate it to node 360 -- To. 361 362 Remove (Asp); 363 Append (Asp, Asps); 364 end Relocate_Aspect; 365 366 -- Local variables 367 368 Asp : Node_Id; 369 Asp_Id : Aspect_Id; 370 Next_Asp : Node_Id; 371 372 -- Start of processing for Move_Or_Merge_Aspects 373 374 begin 375 if Has_Aspects (From) then 376 Asp := First (Aspect_Specifications (From)); 377 while Present (Asp) loop 378 379 -- Store the next aspect now as a potential relocation will alter 380 -- the contents of the list. 381 382 Next_Asp := Next (Asp); 383 384 -- When moving or merging aspects from a subprogram body stub that 385 -- also acts as a spec, relocate only those aspects that may apply 386 -- to a body [stub]. Note that a precondition must also be moved 387 -- to the proper body as the pre/post machinery expects it to be 388 -- there. 389 390 if Nkind (From) = N_Subprogram_Body_Stub 391 and then No (Corresponding_Spec_Of_Stub (From)) 392 then 393 Asp_Id := Get_Aspect_Id (Asp); 394 395 if Aspect_On_Body_Or_Stub_OK (Asp_Id) 396 or else Asp_Id = Aspect_Pre 397 or else Asp_Id = Aspect_Precondition 398 then 399 Relocate_Aspect (Asp); 400 end if; 401 402 -- When moving or merging aspects from a single concurrent type 403 -- declaration, relocate only those aspects that may apply to the 404 -- anonymous object created for the type. 405 406 -- Note: It is better to use Is_Single_Concurrent_Type_Declaration 407 -- here, but Aspects and Sem_Util have incompatible licenses. 408 409 elsif Nkind (Original_Node (From)) in 410 N_Single_Protected_Declaration | N_Single_Task_Declaration 411 then 412 Asp_Id := Get_Aspect_Id (Asp); 413 414 if Aspect_On_Anonymous_Object_OK (Asp_Id) then 415 Relocate_Aspect (Asp); 416 end if; 417 418 -- Default case - relocate the aspect to its new owner 419 420 else 421 Relocate_Aspect (Asp); 422 end if; 423 424 Asp := Next_Asp; 425 end loop; 426 427 -- The relocations may have left node From's aspect specifications 428 -- list empty. If this is the case, simply remove the aspects. 429 430 if Is_Empty_List (Aspect_Specifications (From)) then 431 Remove_Aspects (From); 432 end if; 433 end if; 434 end Move_Or_Merge_Aspects; 435 436 ----------------------------------- 437 -- Permits_Aspect_Specifications -- 438 ----------------------------------- 439 440 Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean := 441 (N_Abstract_Subprogram_Declaration => True, 442 N_Component_Declaration => True, 443 N_Entry_Body => True, 444 N_Entry_Declaration => True, 445 N_Exception_Declaration => True, 446 N_Exception_Renaming_Declaration => True, 447 N_Expression_Function => True, 448 N_Formal_Abstract_Subprogram_Declaration => True, 449 N_Formal_Concrete_Subprogram_Declaration => True, 450 N_Formal_Object_Declaration => True, 451 N_Formal_Package_Declaration => True, 452 N_Formal_Type_Declaration => True, 453 N_Full_Type_Declaration => True, 454 N_Function_Instantiation => True, 455 N_Generic_Package_Declaration => True, 456 N_Generic_Renaming_Declaration => True, 457 N_Generic_Subprogram_Declaration => True, 458 N_Object_Declaration => True, 459 N_Object_Renaming_Declaration => True, 460 N_Package_Body => True, 461 N_Package_Body_Stub => True, 462 N_Package_Declaration => True, 463 N_Package_Instantiation => True, 464 N_Package_Specification => True, 465 N_Package_Renaming_Declaration => True, 466 N_Parameter_Specification => True, 467 N_Private_Extension_Declaration => True, 468 N_Private_Type_Declaration => True, 469 N_Procedure_Instantiation => True, 470 N_Protected_Body => True, 471 N_Protected_Body_Stub => True, 472 N_Protected_Type_Declaration => True, 473 N_Single_Protected_Declaration => True, 474 N_Single_Task_Declaration => True, 475 N_Subprogram_Body => True, 476 N_Subprogram_Body_Stub => True, 477 N_Subprogram_Declaration => True, 478 N_Subprogram_Renaming_Declaration => True, 479 N_Subtype_Declaration => True, 480 N_Task_Body => True, 481 N_Task_Body_Stub => True, 482 N_Task_Type_Declaration => True, 483 others => False); 484 485 function Permits_Aspect_Specifications (N : Node_Id) return Boolean is 486 begin 487 return Has_Aspect_Specifications_Flag (Nkind (N)); 488 end Permits_Aspect_Specifications; 489 490 -------------------- 491 -- Remove_Aspects -- 492 -------------------- 493 494 procedure Remove_Aspects (N : Node_Id) is 495 begin 496 if Has_Aspects (N) then 497 Aspect_Specifications_Hash_Table.Remove (N); 498 Set_Has_Aspects (N, False); 499 end if; 500 end Remove_Aspects; 501 502 ----------------- 503 -- Same_Aspect -- 504 ----------------- 505 506 -- Table used for Same_Aspect, maps aspect to canonical aspect 507 508 type Aspect_To_Aspect_Mapping is array (Aspect_Id) of Aspect_Id; 509 510 function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping; 511 -- Initialize the Canonical_Aspect mapping below 512 513 function Init_Canonical_Aspect return Aspect_To_Aspect_Mapping is 514 Result : Aspect_To_Aspect_Mapping; 515 begin 516 -- They all map to themselves... 517 518 for Aspect in Aspect_Id loop 519 Result (Aspect) := Aspect; 520 end loop; 521 522 -- ...except for these: 523 524 Result (Aspect_Dynamic_Predicate) := Aspect_Predicate; 525 Result (Aspect_Inline_Always) := Aspect_Inline; 526 Result (Aspect_Interrupt_Priority) := Aspect_Priority; 527 Result (Aspect_Postcondition) := Aspect_Post; 528 Result (Aspect_Precondition) := Aspect_Pre; 529 Result (Aspect_Shared) := Aspect_Atomic; 530 Result (Aspect_Static_Predicate) := Aspect_Predicate; 531 Result (Aspect_Type_Invariant) := Aspect_Invariant; 532 533 return Result; 534 end Init_Canonical_Aspect; 535 536 Canonical_Aspect : constant Aspect_To_Aspect_Mapping := 537 Init_Canonical_Aspect; 538 539 function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is 540 begin 541 return Canonical_Aspect (A1) = Canonical_Aspect (A2); 542 end Same_Aspect; 543 544 ------------------------------- 545 -- Set_Aspect_Specifications -- 546 ------------------------------- 547 548 procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is 549 begin 550 pragma Assert (Permits_Aspect_Specifications (N)); 551 pragma Assert (not Has_Aspects (N)); 552 pragma Assert (L /= No_List); 553 554 Set_Has_Aspects (N); 555 Set_Parent (L, N); 556 Aspect_Specifications_Hash_Table.Set (N, L); 557 end Set_Aspect_Specifications; 558 559-- Package initialization sets up Aspect Id hash table 560 561begin 562 for J in Aspect_Id loop 563 Aspect_Id_Hash_Table.Set (Aspect_Names (J), J); 564 end loop; 565end Aspects; 566