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-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 Einfo; use Einfo; 34with Nlists; use Nlists; 35with Sinfo; use Sinfo; 36with Tree_IO; use Tree_IO; 37 38with GNAT.HTable; 39 40package body Aspects is 41 42 -- The following array indicates aspects that a subtype inherits from its 43 -- base type. True means that the subtype inherits the aspect from its base 44 -- type. False means it is not inherited. 45 46 Base_Aspect : constant array (Aspect_Id) of Boolean := 47 (Aspect_Atomic => True, 48 Aspect_Atomic_Components => True, 49 Aspect_Constant_Indexing => True, 50 Aspect_Default_Iterator => True, 51 Aspect_Discard_Names => True, 52 Aspect_Independent_Components => True, 53 Aspect_Iterator_Element => True, 54 Aspect_Type_Invariant => True, 55 Aspect_Unchecked_Union => True, 56 Aspect_Variable_Indexing => True, 57 Aspect_Volatile => True, 58 Aspect_Volatile_Full_Access => True, 59 others => False); 60 61 -- The following array indicates type aspects that are inherited and apply 62 -- to the class-wide type as well. 63 64 Inherited_Aspect : constant array (Aspect_Id) of Boolean := 65 (Aspect_Constant_Indexing => True, 66 Aspect_Default_Iterator => True, 67 Aspect_Implicit_Dereference => True, 68 Aspect_Iterator_Element => True, 69 Aspect_Remote_Types => True, 70 Aspect_Variable_Indexing => True, 71 others => False); 72 73 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id); 74 -- Same as Set_Aspect_Specifications, but does not contain the assertion 75 -- that checks that N does not already have aspect specifications. This 76 -- subprogram is supposed to be used as a part of Tree_Read. When reading 77 -- tree, first read nodes with their basic properties (as Atree.Tree_Read), 78 -- this includes reading the Has_Aspects flag for each node, then we reed 79 -- all the list tables and only after that we call Tree_Read for Aspects. 80 -- That is, when reading the tree, the list of aspects is attached to the 81 -- node that already has Has_Aspects flag set ON. 82 83 ------------------------------------------ 84 -- Hash Table for Aspect Specifications -- 85 ------------------------------------------ 86 87 type AS_Hash_Range is range 0 .. 510; 88 -- Size of hash table headers 89 90 function AS_Hash (F : Node_Id) return AS_Hash_Range; 91 -- Hash function for hash table 92 93 function AS_Hash (F : Node_Id) return AS_Hash_Range is 94 begin 95 return AS_Hash_Range (F mod 511); 96 end AS_Hash; 97 98 package Aspect_Specifications_Hash_Table is new 99 GNAT.HTable.Simple_HTable 100 (Header_Num => AS_Hash_Range, 101 Element => List_Id, 102 No_Element => No_List, 103 Key => Node_Id, 104 Hash => AS_Hash, 105 Equal => "="); 106 107 ------------------------------------- 108 -- Hash Table for Aspect Id Values -- 109 ------------------------------------- 110 111 type AI_Hash_Range is range 0 .. 112; 112 -- Size of hash table headers 113 114 function AI_Hash (F : Name_Id) return AI_Hash_Range; 115 -- Hash function for hash table 116 117 function AI_Hash (F : Name_Id) return AI_Hash_Range is 118 begin 119 return AI_Hash_Range (F mod 113); 120 end AI_Hash; 121 122 package Aspect_Id_Hash_Table is new 123 GNAT.HTable.Simple_HTable 124 (Header_Num => AI_Hash_Range, 125 Element => Aspect_Id, 126 No_Element => No_Aspect, 127 Key => Name_Id, 128 Hash => AI_Hash, 129 Equal => "="); 130 131 --------------------------- 132 -- Aspect_Specifications -- 133 --------------------------- 134 135 function Aspect_Specifications (N : Node_Id) return List_Id is 136 begin 137 if Has_Aspects (N) then 138 return Aspect_Specifications_Hash_Table.Get (N); 139 else 140 return No_List; 141 end if; 142 end Aspect_Specifications; 143 144 -------------------------------- 145 -- Aspects_On_Body_Or_Stub_OK -- 146 -------------------------------- 147 148 function Aspects_On_Body_Or_Stub_OK (N : Node_Id) return Boolean is 149 Aspect : Node_Id; 150 Aspects : List_Id; 151 152 begin 153 -- The routine should be invoked on a body [stub] with aspects 154 155 pragma Assert (Has_Aspects (N)); 156 pragma Assert (Nkind (N) in N_Body_Stub 157 or else Nkind_In (N, N_Entry_Body, 158 N_Package_Body, 159 N_Protected_Body, 160 N_Subprogram_Body, 161 N_Task_Body)); 162 163 -- Look through all aspects and see whether they can be applied to a 164 -- body [stub]. 165 166 Aspects := Aspect_Specifications (N); 167 Aspect := First (Aspects); 168 while Present (Aspect) loop 169 if not Aspect_On_Body_Or_Stub_OK (Get_Aspect_Id (Aspect)) then 170 return False; 171 end if; 172 173 Next (Aspect); 174 end loop; 175 176 return True; 177 end Aspects_On_Body_Or_Stub_OK; 178 179 ---------------------- 180 -- Exchange_Aspects -- 181 ---------------------- 182 183 procedure Exchange_Aspects (N1 : Node_Id; N2 : Node_Id) is 184 begin 185 pragma Assert 186 (Permits_Aspect_Specifications (N1) 187 and then Permits_Aspect_Specifications (N2)); 188 189 -- Perform the exchange only when both nodes have lists to be swapped 190 191 if Has_Aspects (N1) and then Has_Aspects (N2) then 192 declare 193 L1 : constant List_Id := Aspect_Specifications (N1); 194 L2 : constant List_Id := Aspect_Specifications (N2); 195 begin 196 Set_Parent (L1, N2); 197 Set_Parent (L2, N1); 198 Aspect_Specifications_Hash_Table.Set (N1, L2); 199 Aspect_Specifications_Hash_Table.Set (N2, L1); 200 end; 201 end if; 202 end Exchange_Aspects; 203 204 ----------------- 205 -- Find_Aspect -- 206 ----------------- 207 208 function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id is 209 Decl : Node_Id; 210 Item : Node_Id; 211 Owner : Entity_Id; 212 Spec : Node_Id; 213 214 begin 215 Owner := Id; 216 217 -- Handle various cases of base or inherited aspects for types 218 219 if Is_Type (Id) then 220 if Base_Aspect (A) then 221 Owner := Base_Type (Owner); 222 end if; 223 224 if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then 225 Owner := Root_Type (Owner); 226 end if; 227 228 if Is_Private_Type (Owner) 229 and then Present (Full_View (Owner)) 230 and then not Operational_Aspect (A) 231 then 232 Owner := Full_View (Owner); 233 end if; 234 end if; 235 236 -- Search the representation items for the desired aspect 237 238 Item := First_Rep_Item (Owner); 239 while Present (Item) loop 240 if Nkind (Item) = N_Aspect_Specification 241 and then Get_Aspect_Id (Item) = A 242 then 243 return Item; 244 end if; 245 246 Next_Rep_Item (Item); 247 end loop; 248 249 -- Note that not all aspects are added to the chain of representation 250 -- items. In such cases, search the list of aspect specifications. First 251 -- find the declaration node where the aspects reside. This is usually 252 -- the parent or the parent of the parent. 253 254 Decl := Parent (Owner); 255 if not Permits_Aspect_Specifications (Decl) then 256 Decl := Parent (Decl); 257 end if; 258 259 -- Search the list of aspect specifications for the desired aspect 260 261 if Permits_Aspect_Specifications (Decl) then 262 Spec := First (Aspect_Specifications (Decl)); 263 while Present (Spec) loop 264 if Get_Aspect_Id (Spec) = A then 265 return Spec; 266 end if; 267 268 Next (Spec); 269 end loop; 270 end if; 271 272 -- The entity does not carry any aspects or the desired aspect was not 273 -- found. 274 275 return Empty; 276 end Find_Aspect; 277 278 -------------------------- 279 -- Find_Value_Of_Aspect -- 280 -------------------------- 281 282 function Find_Value_Of_Aspect 283 (Id : Entity_Id; 284 A : Aspect_Id) return Node_Id 285 is 286 Spec : constant Node_Id := Find_Aspect (Id, A); 287 288 begin 289 if Present (Spec) then 290 if A = Aspect_Default_Iterator then 291 return Expression (Aspect_Rep_Item (Spec)); 292 else 293 return Expression (Spec); 294 end if; 295 end if; 296 297 return Empty; 298 end Find_Value_Of_Aspect; 299 300 ------------------- 301 -- Get_Aspect_Id -- 302 ------------------- 303 304 function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is 305 begin 306 return Aspect_Id_Hash_Table.Get (Name); 307 end Get_Aspect_Id; 308 309 function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is 310 begin 311 pragma Assert (Nkind (Aspect) = N_Aspect_Specification); 312 return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect))); 313 end Get_Aspect_Id; 314 315 ---------------- 316 -- Has_Aspect -- 317 ---------------- 318 319 function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is 320 begin 321 return Present (Find_Aspect (Id, A)); 322 end Has_Aspect; 323 324 ------------------ 325 -- Move_Aspects -- 326 ------------------ 327 328 procedure Move_Aspects (From : Node_Id; To : Node_Id) is 329 pragma Assert (not Has_Aspects (To)); 330 begin 331 if Has_Aspects (From) then 332 Set_Aspect_Specifications (To, Aspect_Specifications (From)); 333 Aspect_Specifications_Hash_Table.Remove (From); 334 Set_Has_Aspects (From, False); 335 end if; 336 end Move_Aspects; 337 338 --------------------------- 339 -- Move_Or_Merge_Aspects -- 340 --------------------------- 341 342 procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is 343 procedure Relocate_Aspect (Asp : Node_Id); 344 -- Move aspect specification Asp to the aspect specifications of node To 345 346 --------------------- 347 -- Relocate_Aspect -- 348 --------------------- 349 350 procedure Relocate_Aspect (Asp : Node_Id) is 351 Asps : List_Id; 352 353 begin 354 if Has_Aspects (To) then 355 Asps := Aspect_Specifications (To); 356 357 -- Create a new aspect specification list for node To 358 359 else 360 Asps := New_List; 361 Set_Aspect_Specifications (To, Asps); 362 Set_Has_Aspects (To); 363 end if; 364 365 -- Remove the aspect from its original owner and relocate it to node 366 -- To. 367 368 Remove (Asp); 369 Append (Asp, Asps); 370 end Relocate_Aspect; 371 372 -- Local variables 373 374 Asp : Node_Id; 375 Asp_Id : Aspect_Id; 376 Next_Asp : Node_Id; 377 378 -- Start of processing for Move_Or_Merge_Aspects 379 380 begin 381 if Has_Aspects (From) then 382 Asp := First (Aspect_Specifications (From)); 383 while Present (Asp) loop 384 385 -- Store the next aspect now as a potential relocation will alter 386 -- the contents of the list. 387 388 Next_Asp := Next (Asp); 389 390 -- When moving or merging aspects from a subprogram body stub that 391 -- also acts as a spec, relocate only those aspects that may apply 392 -- to a body [stub]. Note that a precondition must also be moved 393 -- to the proper body as the pre/post machinery expects it to be 394 -- there. 395 396 if Nkind (From) = N_Subprogram_Body_Stub 397 and then No (Corresponding_Spec_Of_Stub (From)) 398 then 399 Asp_Id := Get_Aspect_Id (Asp); 400 401 if Aspect_On_Body_Or_Stub_OK (Asp_Id) 402 or else Asp_Id = Aspect_Pre 403 or else Asp_Id = Aspect_Precondition 404 then 405 Relocate_Aspect (Asp); 406 end if; 407 408 -- When moving or merging aspects from a single concurrent type 409 -- declaration, relocate only those aspects that may apply to the 410 -- anonymous object created for the type. 411 412 -- Note: It is better to use Is_Single_Concurrent_Type_Declaration 413 -- here, but Aspects and Sem_Util have incompatible licenses. 414 415 elsif Nkind_In 416 (Original_Node (From), N_Single_Protected_Declaration, 417 N_Single_Task_Declaration) 418 then 419 Asp_Id := Get_Aspect_Id (Asp); 420 421 if Aspect_On_Anonymous_Object_OK (Asp_Id) then 422 Relocate_Aspect (Asp); 423 end if; 424 425 -- Default case - relocate the aspect to its new owner 426 427 else 428 Relocate_Aspect (Asp); 429 end if; 430 431 Asp := Next_Asp; 432 end loop; 433 434 -- The relocations may have left node From's aspect specifications 435 -- list empty. If this is the case, simply remove the aspects. 436 437 if Is_Empty_List (Aspect_Specifications (From)) then 438 Remove_Aspects (From); 439 end if; 440 end if; 441 end Move_Or_Merge_Aspects; 442 443 ----------------------------------- 444 -- Permits_Aspect_Specifications -- 445 ----------------------------------- 446 447 Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean := 448 (N_Abstract_Subprogram_Declaration => True, 449 N_Component_Declaration => True, 450 N_Entry_Body => True, 451 N_Entry_Declaration => True, 452 N_Exception_Declaration => True, 453 N_Exception_Renaming_Declaration => True, 454 N_Expression_Function => True, 455 N_Formal_Abstract_Subprogram_Declaration => True, 456 N_Formal_Concrete_Subprogram_Declaration => True, 457 N_Formal_Object_Declaration => True, 458 N_Formal_Package_Declaration => True, 459 N_Formal_Type_Declaration => True, 460 N_Full_Type_Declaration => True, 461 N_Function_Instantiation => True, 462 N_Generic_Package_Declaration => True, 463 N_Generic_Renaming_Declaration => True, 464 N_Generic_Subprogram_Declaration => True, 465 N_Object_Declaration => True, 466 N_Object_Renaming_Declaration => True, 467 N_Package_Body => True, 468 N_Package_Body_Stub => True, 469 N_Package_Declaration => True, 470 N_Package_Instantiation => True, 471 N_Package_Specification => True, 472 N_Package_Renaming_Declaration => True, 473 N_Private_Extension_Declaration => True, 474 N_Private_Type_Declaration => True, 475 N_Procedure_Instantiation => True, 476 N_Protected_Body => True, 477 N_Protected_Body_Stub => True, 478 N_Protected_Type_Declaration => True, 479 N_Single_Protected_Declaration => True, 480 N_Single_Task_Declaration => True, 481 N_Subprogram_Body => True, 482 N_Subprogram_Body_Stub => True, 483 N_Subprogram_Declaration => True, 484 N_Subprogram_Renaming_Declaration => True, 485 N_Subtype_Declaration => True, 486 N_Task_Body => True, 487 N_Task_Body_Stub => True, 488 N_Task_Type_Declaration => True, 489 others => False); 490 491 function Permits_Aspect_Specifications (N : Node_Id) return Boolean is 492 begin 493 return Has_Aspect_Specifications_Flag (Nkind (N)); 494 end Permits_Aspect_Specifications; 495 496 -------------------- 497 -- Remove_Aspects -- 498 -------------------- 499 500 procedure Remove_Aspects (N : Node_Id) is 501 begin 502 if Has_Aspects (N) then 503 Aspect_Specifications_Hash_Table.Remove (N); 504 Set_Has_Aspects (N, False); 505 end if; 506 end Remove_Aspects; 507 508 ----------------- 509 -- Same_Aspect -- 510 ----------------- 511 512 -- Table used for Same_Aspect, maps aspect to canonical aspect 513 514 Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id := 515 (No_Aspect => No_Aspect, 516 Aspect_Abstract_State => Aspect_Abstract_State, 517 Aspect_Address => Aspect_Address, 518 Aspect_Alignment => Aspect_Alignment, 519 Aspect_All_Calls_Remote => Aspect_All_Calls_Remote, 520 Aspect_Annotate => Aspect_Annotate, 521 Aspect_Async_Readers => Aspect_Async_Readers, 522 Aspect_Async_Writers => Aspect_Async_Writers, 523 Aspect_Asynchronous => Aspect_Asynchronous, 524 Aspect_Atomic => Aspect_Atomic, 525 Aspect_Atomic_Components => Aspect_Atomic_Components, 526 Aspect_Attach_Handler => Aspect_Attach_Handler, 527 Aspect_Bit_Order => Aspect_Bit_Order, 528 Aspect_Component_Size => Aspect_Component_Size, 529 Aspect_Constant_After_Elaboration => Aspect_Constant_After_Elaboration, 530 Aspect_Constant_Indexing => Aspect_Constant_Indexing, 531 Aspect_Contract_Cases => Aspect_Contract_Cases, 532 Aspect_Convention => Aspect_Convention, 533 Aspect_CPU => Aspect_CPU, 534 Aspect_Default_Component_Value => Aspect_Default_Component_Value, 535 Aspect_Default_Initial_Condition => Aspect_Default_Initial_Condition, 536 Aspect_Default_Iterator => Aspect_Default_Iterator, 537 Aspect_Default_Storage_Pool => Aspect_Default_Storage_Pool, 538 Aspect_Default_Value => Aspect_Default_Value, 539 Aspect_Depends => Aspect_Depends, 540 Aspect_Dimension => Aspect_Dimension, 541 Aspect_Dimension_System => Aspect_Dimension_System, 542 Aspect_Disable_Controlled => Aspect_Disable_Controlled, 543 Aspect_Discard_Names => Aspect_Discard_Names, 544 Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, 545 Aspect_Dynamic_Predicate => Aspect_Predicate, 546 Aspect_Effective_Reads => Aspect_Effective_Reads, 547 Aspect_Effective_Writes => Aspect_Effective_Writes, 548 Aspect_Elaborate_Body => Aspect_Elaborate_Body, 549 Aspect_Export => Aspect_Export, 550 Aspect_Extensions_Visible => Aspect_Extensions_Visible, 551 Aspect_External_Name => Aspect_External_Name, 552 Aspect_External_Tag => Aspect_External_Tag, 553 Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, 554 Aspect_Ghost => Aspect_Ghost, 555 Aspect_Global => Aspect_Global, 556 Aspect_Implicit_Dereference => Aspect_Implicit_Dereference, 557 Aspect_Import => Aspect_Import, 558 Aspect_Independent => Aspect_Independent, 559 Aspect_Independent_Components => Aspect_Independent_Components, 560 Aspect_Inline => Aspect_Inline, 561 Aspect_Inline_Always => Aspect_Inline, 562 Aspect_Initial_Condition => Aspect_Initial_Condition, 563 Aspect_Initializes => Aspect_Initializes, 564 Aspect_Input => Aspect_Input, 565 Aspect_Interrupt_Handler => Aspect_Interrupt_Handler, 566 Aspect_Interrupt_Priority => Aspect_Priority, 567 Aspect_Invariant => Aspect_Invariant, 568 Aspect_Iterable => Aspect_Iterable, 569 Aspect_Iterator_Element => Aspect_Iterator_Element, 570 Aspect_Link_Name => Aspect_Link_Name, 571 Aspect_Linker_Section => Aspect_Linker_Section, 572 Aspect_Lock_Free => Aspect_Lock_Free, 573 Aspect_Machine_Radix => Aspect_Machine_Radix, 574 Aspect_Max_Entry_Queue_Depth => Aspect_Max_Entry_Queue_Depth, 575 Aspect_Max_Entry_Queue_Length => Aspect_Max_Entry_Queue_Length, 576 Aspect_Max_Queue_Length => Aspect_Max_Queue_Length, 577 Aspect_No_Caching => Aspect_No_Caching, 578 Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, 579 Aspect_No_Inline => Aspect_No_Inline, 580 Aspect_No_Return => Aspect_No_Return, 581 Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams, 582 Aspect_Obsolescent => Aspect_Obsolescent, 583 Aspect_Object_Size => Aspect_Object_Size, 584 Aspect_Output => Aspect_Output, 585 Aspect_Pack => Aspect_Pack, 586 Aspect_Part_Of => Aspect_Part_Of, 587 Aspect_Persistent_BSS => Aspect_Persistent_BSS, 588 Aspect_Post => Aspect_Post, 589 Aspect_Postcondition => Aspect_Post, 590 Aspect_Pre => Aspect_Pre, 591 Aspect_Precondition => Aspect_Pre, 592 Aspect_Predicate => Aspect_Predicate, 593 Aspect_Predicate_Failure => Aspect_Predicate_Failure, 594 Aspect_Preelaborate => Aspect_Preelaborate, 595 Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization, 596 Aspect_Priority => Aspect_Priority, 597 Aspect_Pure => Aspect_Pure, 598 Aspect_Pure_Function => Aspect_Pure_Function, 599 Aspect_Refined_Depends => Aspect_Refined_Depends, 600 Aspect_Refined_Global => Aspect_Refined_Global, 601 Aspect_Refined_Post => Aspect_Refined_Post, 602 Aspect_Refined_State => Aspect_Refined_State, 603 Aspect_Remote_Access_Type => Aspect_Remote_Access_Type, 604 Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, 605 Aspect_Remote_Types => Aspect_Remote_Types, 606 Aspect_Read => Aspect_Read, 607 Aspect_Relative_Deadline => Aspect_Relative_Deadline, 608 Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order, 609 Aspect_Secondary_Stack_Size => Aspect_Secondary_Stack_Size, 610 Aspect_Shared => Aspect_Atomic, 611 Aspect_Shared_Passive => Aspect_Shared_Passive, 612 Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool, 613 Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type, 614 Aspect_Size => Aspect_Size, 615 Aspect_Small => Aspect_Small, 616 Aspect_SPARK_Mode => Aspect_SPARK_Mode, 617 Aspect_Static_Predicate => Aspect_Predicate, 618 Aspect_Storage_Pool => Aspect_Storage_Pool, 619 Aspect_Storage_Size => Aspect_Storage_Size, 620 Aspect_Stream_Size => Aspect_Stream_Size, 621 Aspect_Suppress => Aspect_Suppress, 622 Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info, 623 Aspect_Suppress_Initialization => Aspect_Suppress_Initialization, 624 Aspect_Synchronization => Aspect_Synchronization, 625 Aspect_Test_Case => Aspect_Test_Case, 626 Aspect_Thread_Local_Storage => Aspect_Thread_Local_Storage, 627 Aspect_Type_Invariant => Aspect_Invariant, 628 Aspect_Unchecked_Union => Aspect_Unchecked_Union, 629 Aspect_Unimplemented => Aspect_Unimplemented, 630 Aspect_Universal_Aliasing => Aspect_Universal_Aliasing, 631 Aspect_Universal_Data => Aspect_Universal_Data, 632 Aspect_Unmodified => Aspect_Unmodified, 633 Aspect_Unreferenced => Aspect_Unreferenced, 634 Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects, 635 Aspect_Unsuppress => Aspect_Unsuppress, 636 Aspect_Variable_Indexing => Aspect_Variable_Indexing, 637 Aspect_Value_Size => Aspect_Value_Size, 638 Aspect_Volatile => Aspect_Volatile, 639 Aspect_Volatile_Components => Aspect_Volatile_Components, 640 Aspect_Volatile_Full_Access => Aspect_Volatile_Full_Access, 641 Aspect_Volatile_Function => Aspect_Volatile_Function, 642 Aspect_Warnings => Aspect_Warnings, 643 Aspect_Write => Aspect_Write); 644 645 function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is 646 begin 647 return Canonical_Aspect (A1) = Canonical_Aspect (A2); 648 end Same_Aspect; 649 650 ------------------------------- 651 -- Set_Aspect_Specifications -- 652 ------------------------------- 653 654 procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is 655 begin 656 pragma Assert (Permits_Aspect_Specifications (N)); 657 pragma Assert (not Has_Aspects (N)); 658 pragma Assert (L /= No_List); 659 660 Set_Has_Aspects (N); 661 Set_Parent (L, N); 662 Aspect_Specifications_Hash_Table.Set (N, L); 663 end Set_Aspect_Specifications; 664 665 ---------------------------------------- 666 -- Set_Aspect_Specifications_No_Check -- 667 ---------------------------------------- 668 669 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is 670 begin 671 pragma Assert (Permits_Aspect_Specifications (N)); 672 pragma Assert (L /= No_List); 673 674 Set_Has_Aspects (N); 675 Set_Parent (L, N); 676 Aspect_Specifications_Hash_Table.Set (N, L); 677 end Set_Aspect_Specifications_No_Check; 678 679 --------------- 680 -- Tree_Read -- 681 --------------- 682 683 procedure Tree_Read is 684 Node : Node_Id; 685 List : List_Id; 686 begin 687 loop 688 Tree_Read_Int (Int (Node)); 689 Tree_Read_Int (Int (List)); 690 exit when List = No_List; 691 Set_Aspect_Specifications_No_Check (Node, List); 692 end loop; 693 end Tree_Read; 694 695 ---------------- 696 -- Tree_Write -- 697 ---------------- 698 699 procedure Tree_Write is 700 Node : Node_Id := Empty; 701 List : List_Id; 702 begin 703 Aspect_Specifications_Hash_Table.Get_First (Node, List); 704 loop 705 Tree_Write_Int (Int (Node)); 706 Tree_Write_Int (Int (List)); 707 exit when List = No_List; 708 Aspect_Specifications_Hash_Table.Get_Next (Node, List); 709 end loop; 710 end Tree_Write; 711 712-- Package initialization sets up Aspect Id hash table 713 714begin 715 for J in Aspect_Id loop 716 Aspect_Id_Hash_Table.Set (Aspect_Names (J), J); 717 end loop; 718end Aspects; 719