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) and then Present (Full_View (Owner)) then 229 Owner := Full_View (Owner); 230 end if; 231 end if; 232 233 -- Search the representation items for the desired aspect 234 235 Item := First_Rep_Item (Owner); 236 while Present (Item) loop 237 if Nkind (Item) = N_Aspect_Specification 238 and then Get_Aspect_Id (Item) = A 239 then 240 return Item; 241 end if; 242 243 Next_Rep_Item (Item); 244 end loop; 245 246 -- Note that not all aspects are added to the chain of representation 247 -- items. In such cases, search the list of aspect specifications. First 248 -- find the declaration node where the aspects reside. This is usually 249 -- the parent or the parent of the parent. 250 251 Decl := Parent (Owner); 252 if not Permits_Aspect_Specifications (Decl) then 253 Decl := Parent (Decl); 254 end if; 255 256 -- Search the list of aspect specifications for the desired aspect 257 258 if Permits_Aspect_Specifications (Decl) then 259 Spec := First (Aspect_Specifications (Decl)); 260 while Present (Spec) loop 261 if Get_Aspect_Id (Spec) = A then 262 return Spec; 263 end if; 264 265 Next (Spec); 266 end loop; 267 end if; 268 269 -- The entity does not carry any aspects or the desired aspect was not 270 -- found. 271 272 return Empty; 273 end Find_Aspect; 274 275 -------------------------- 276 -- Find_Value_Of_Aspect -- 277 -------------------------- 278 279 function Find_Value_Of_Aspect 280 (Id : Entity_Id; 281 A : Aspect_Id) return Node_Id 282 is 283 Spec : constant Node_Id := Find_Aspect (Id, A); 284 285 begin 286 if Present (Spec) then 287 if A = Aspect_Default_Iterator then 288 return Expression (Aspect_Rep_Item (Spec)); 289 else 290 return Expression (Spec); 291 end if; 292 end if; 293 294 return Empty; 295 end Find_Value_Of_Aspect; 296 297 ------------------- 298 -- Get_Aspect_Id -- 299 ------------------- 300 301 function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is 302 begin 303 return Aspect_Id_Hash_Table.Get (Name); 304 end Get_Aspect_Id; 305 306 function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is 307 begin 308 pragma Assert (Nkind (Aspect) = N_Aspect_Specification); 309 return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect))); 310 end Get_Aspect_Id; 311 312 ---------------- 313 -- Has_Aspect -- 314 ---------------- 315 316 function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is 317 begin 318 return Present (Find_Aspect (Id, A)); 319 end Has_Aspect; 320 321 ------------------ 322 -- Move_Aspects -- 323 ------------------ 324 325 procedure Move_Aspects (From : Node_Id; To : Node_Id) is 326 pragma Assert (not Has_Aspects (To)); 327 begin 328 if Has_Aspects (From) then 329 Set_Aspect_Specifications (To, Aspect_Specifications (From)); 330 Aspect_Specifications_Hash_Table.Remove (From); 331 Set_Has_Aspects (From, False); 332 end if; 333 end Move_Aspects; 334 335 --------------------------- 336 -- Move_Or_Merge_Aspects -- 337 --------------------------- 338 339 procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is 340 procedure Relocate_Aspect (Asp : Node_Id); 341 -- Move aspect specification Asp to the aspect specifications of node To 342 343 --------------------- 344 -- Relocate_Aspect -- 345 --------------------- 346 347 procedure Relocate_Aspect (Asp : Node_Id) is 348 Asps : List_Id; 349 350 begin 351 if Has_Aspects (To) then 352 Asps := Aspect_Specifications (To); 353 354 -- Create a new aspect specification list for node To 355 356 else 357 Asps := New_List; 358 Set_Aspect_Specifications (To, Asps); 359 Set_Has_Aspects (To); 360 end if; 361 362 -- Remove the aspect from its original owner and relocate it to node 363 -- To. 364 365 Remove (Asp); 366 Append (Asp, Asps); 367 end Relocate_Aspect; 368 369 -- Local variables 370 371 Asp : Node_Id; 372 Asp_Id : Aspect_Id; 373 Next_Asp : Node_Id; 374 375 -- Start of processing for Move_Or_Merge_Aspects 376 377 begin 378 if Has_Aspects (From) then 379 Asp := First (Aspect_Specifications (From)); 380 while Present (Asp) loop 381 382 -- Store the next aspect now as a potential relocation will alter 383 -- the contents of the list. 384 385 Next_Asp := Next (Asp); 386 387 -- When moving or merging aspects from a subprogram body stub that 388 -- also acts as a spec, relocate only those aspects that may apply 389 -- to a body [stub]. Note that a precondition must also be moved 390 -- to the proper body as the pre/post machinery expects it to be 391 -- there. 392 393 if Nkind (From) = N_Subprogram_Body_Stub 394 and then No (Corresponding_Spec_Of_Stub (From)) 395 then 396 Asp_Id := Get_Aspect_Id (Asp); 397 398 if Aspect_On_Body_Or_Stub_OK (Asp_Id) 399 or else Asp_Id = Aspect_Pre 400 or else Asp_Id = Aspect_Precondition 401 then 402 Relocate_Aspect (Asp); 403 end if; 404 405 -- When moving or merging aspects from a single concurrent type 406 -- declaration, relocate only those aspects that may apply to the 407 -- anonymous object created for the type. 408 409 -- Note: It is better to use Is_Single_Concurrent_Type_Declaration 410 -- here, but Aspects and Sem_Util have incompatible licenses. 411 412 elsif Nkind_In 413 (Original_Node (From), N_Single_Protected_Declaration, 414 N_Single_Task_Declaration) 415 then 416 Asp_Id := Get_Aspect_Id (Asp); 417 418 if Aspect_On_Anonymous_Object_OK (Asp_Id) then 419 Relocate_Aspect (Asp); 420 end if; 421 422 -- Default case - relocate the aspect to its new owner 423 424 else 425 Relocate_Aspect (Asp); 426 end if; 427 428 Asp := Next_Asp; 429 end loop; 430 431 -- The relocations may have left node From's aspect specifications 432 -- list empty. If this is the case, simply remove the aspects. 433 434 if Is_Empty_List (Aspect_Specifications (From)) then 435 Remove_Aspects (From); 436 end if; 437 end if; 438 end Move_Or_Merge_Aspects; 439 440 ----------------------------------- 441 -- Permits_Aspect_Specifications -- 442 ----------------------------------- 443 444 Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean := 445 (N_Abstract_Subprogram_Declaration => True, 446 N_Component_Declaration => True, 447 N_Entry_Body => True, 448 N_Entry_Declaration => True, 449 N_Exception_Declaration => True, 450 N_Exception_Renaming_Declaration => True, 451 N_Expression_Function => True, 452 N_Formal_Abstract_Subprogram_Declaration => True, 453 N_Formal_Concrete_Subprogram_Declaration => True, 454 N_Formal_Object_Declaration => True, 455 N_Formal_Package_Declaration => True, 456 N_Formal_Type_Declaration => True, 457 N_Full_Type_Declaration => True, 458 N_Function_Instantiation => True, 459 N_Generic_Package_Declaration => True, 460 N_Generic_Renaming_Declaration => True, 461 N_Generic_Subprogram_Declaration => True, 462 N_Object_Declaration => True, 463 N_Object_Renaming_Declaration => True, 464 N_Package_Body => True, 465 N_Package_Body_Stub => True, 466 N_Package_Declaration => True, 467 N_Package_Instantiation => True, 468 N_Package_Specification => True, 469 N_Package_Renaming_Declaration => True, 470 N_Private_Extension_Declaration => True, 471 N_Private_Type_Declaration => True, 472 N_Procedure_Instantiation => True, 473 N_Protected_Body => True, 474 N_Protected_Body_Stub => True, 475 N_Protected_Type_Declaration => True, 476 N_Single_Protected_Declaration => True, 477 N_Single_Task_Declaration => True, 478 N_Subprogram_Body => True, 479 N_Subprogram_Body_Stub => True, 480 N_Subprogram_Declaration => True, 481 N_Subprogram_Renaming_Declaration => True, 482 N_Subtype_Declaration => True, 483 N_Task_Body => True, 484 N_Task_Body_Stub => True, 485 N_Task_Type_Declaration => True, 486 others => False); 487 488 function Permits_Aspect_Specifications (N : Node_Id) return Boolean is 489 begin 490 return Has_Aspect_Specifications_Flag (Nkind (N)); 491 end Permits_Aspect_Specifications; 492 493 -------------------- 494 -- Remove_Aspects -- 495 -------------------- 496 497 procedure Remove_Aspects (N : Node_Id) is 498 begin 499 if Has_Aspects (N) then 500 Aspect_Specifications_Hash_Table.Remove (N); 501 Set_Has_Aspects (N, False); 502 end if; 503 end Remove_Aspects; 504 505 ----------------- 506 -- Same_Aspect -- 507 ----------------- 508 509 -- Table used for Same_Aspect, maps aspect to canonical aspect 510 511 Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id := 512 (No_Aspect => No_Aspect, 513 Aspect_Abstract_State => Aspect_Abstract_State, 514 Aspect_Address => Aspect_Address, 515 Aspect_Alignment => Aspect_Alignment, 516 Aspect_All_Calls_Remote => Aspect_All_Calls_Remote, 517 Aspect_Annotate => Aspect_Annotate, 518 Aspect_Async_Readers => Aspect_Async_Readers, 519 Aspect_Async_Writers => Aspect_Async_Writers, 520 Aspect_Asynchronous => Aspect_Asynchronous, 521 Aspect_Atomic => Aspect_Atomic, 522 Aspect_Atomic_Components => Aspect_Atomic_Components, 523 Aspect_Attach_Handler => Aspect_Attach_Handler, 524 Aspect_Bit_Order => Aspect_Bit_Order, 525 Aspect_Component_Size => Aspect_Component_Size, 526 Aspect_Constant_After_Elaboration => Aspect_Constant_After_Elaboration, 527 Aspect_Constant_Indexing => Aspect_Constant_Indexing, 528 Aspect_Contract_Cases => Aspect_Contract_Cases, 529 Aspect_Convention => Aspect_Convention, 530 Aspect_CPU => Aspect_CPU, 531 Aspect_Default_Component_Value => Aspect_Default_Component_Value, 532 Aspect_Default_Initial_Condition => Aspect_Default_Initial_Condition, 533 Aspect_Default_Iterator => Aspect_Default_Iterator, 534 Aspect_Default_Storage_Pool => Aspect_Default_Storage_Pool, 535 Aspect_Default_Value => Aspect_Default_Value, 536 Aspect_Depends => Aspect_Depends, 537 Aspect_Dimension => Aspect_Dimension, 538 Aspect_Dimension_System => Aspect_Dimension_System, 539 Aspect_Disable_Controlled => Aspect_Disable_Controlled, 540 Aspect_Discard_Names => Aspect_Discard_Names, 541 Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, 542 Aspect_Dynamic_Predicate => Aspect_Predicate, 543 Aspect_Effective_Reads => Aspect_Effective_Reads, 544 Aspect_Effective_Writes => Aspect_Effective_Writes, 545 Aspect_Elaborate_Body => Aspect_Elaborate_Body, 546 Aspect_Export => Aspect_Export, 547 Aspect_Extensions_Visible => Aspect_Extensions_Visible, 548 Aspect_External_Name => Aspect_External_Name, 549 Aspect_External_Tag => Aspect_External_Tag, 550 Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, 551 Aspect_Ghost => Aspect_Ghost, 552 Aspect_Global => Aspect_Global, 553 Aspect_Implicit_Dereference => Aspect_Implicit_Dereference, 554 Aspect_Import => Aspect_Import, 555 Aspect_Independent => Aspect_Independent, 556 Aspect_Independent_Components => Aspect_Independent_Components, 557 Aspect_Inline => Aspect_Inline, 558 Aspect_Inline_Always => Aspect_Inline, 559 Aspect_Initial_Condition => Aspect_Initial_Condition, 560 Aspect_Initializes => Aspect_Initializes, 561 Aspect_Input => Aspect_Input, 562 Aspect_Interrupt_Handler => Aspect_Interrupt_Handler, 563 Aspect_Interrupt_Priority => Aspect_Priority, 564 Aspect_Invariant => Aspect_Invariant, 565 Aspect_Iterable => Aspect_Iterable, 566 Aspect_Iterator_Element => Aspect_Iterator_Element, 567 Aspect_Link_Name => Aspect_Link_Name, 568 Aspect_Linker_Section => Aspect_Linker_Section, 569 Aspect_Lock_Free => Aspect_Lock_Free, 570 Aspect_Machine_Radix => Aspect_Machine_Radix, 571 Aspect_Max_Entry_Queue_Depth => Aspect_Max_Entry_Queue_Depth, 572 Aspect_Max_Queue_Length => Aspect_Max_Queue_Length, 573 Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, 574 Aspect_No_Inline => Aspect_No_Inline, 575 Aspect_No_Return => Aspect_No_Return, 576 Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams, 577 Aspect_Obsolescent => Aspect_Obsolescent, 578 Aspect_Object_Size => Aspect_Object_Size, 579 Aspect_Output => Aspect_Output, 580 Aspect_Pack => Aspect_Pack, 581 Aspect_Part_Of => Aspect_Part_Of, 582 Aspect_Persistent_BSS => Aspect_Persistent_BSS, 583 Aspect_Post => Aspect_Post, 584 Aspect_Postcondition => Aspect_Post, 585 Aspect_Pre => Aspect_Pre, 586 Aspect_Precondition => Aspect_Pre, 587 Aspect_Predicate => Aspect_Predicate, 588 Aspect_Predicate_Failure => Aspect_Predicate_Failure, 589 Aspect_Preelaborate => Aspect_Preelaborate, 590 Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization, 591 Aspect_Priority => Aspect_Priority, 592 Aspect_Pure => Aspect_Pure, 593 Aspect_Pure_Function => Aspect_Pure_Function, 594 Aspect_Refined_Depends => Aspect_Refined_Depends, 595 Aspect_Refined_Global => Aspect_Refined_Global, 596 Aspect_Refined_Post => Aspect_Refined_Post, 597 Aspect_Refined_State => Aspect_Refined_State, 598 Aspect_Remote_Access_Type => Aspect_Remote_Access_Type, 599 Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, 600 Aspect_Remote_Types => Aspect_Remote_Types, 601 Aspect_Read => Aspect_Read, 602 Aspect_Relative_Deadline => Aspect_Relative_Deadline, 603 Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order, 604 Aspect_Secondary_Stack_Size => Aspect_Secondary_Stack_Size, 605 Aspect_Shared => Aspect_Atomic, 606 Aspect_Shared_Passive => Aspect_Shared_Passive, 607 Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool, 608 Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type, 609 Aspect_Size => Aspect_Size, 610 Aspect_Small => Aspect_Small, 611 Aspect_SPARK_Mode => Aspect_SPARK_Mode, 612 Aspect_Static_Predicate => Aspect_Predicate, 613 Aspect_Storage_Pool => Aspect_Storage_Pool, 614 Aspect_Storage_Size => Aspect_Storage_Size, 615 Aspect_Stream_Size => Aspect_Stream_Size, 616 Aspect_Suppress => Aspect_Suppress, 617 Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info, 618 Aspect_Suppress_Initialization => Aspect_Suppress_Initialization, 619 Aspect_Synchronization => Aspect_Synchronization, 620 Aspect_Test_Case => Aspect_Test_Case, 621 Aspect_Thread_Local_Storage => Aspect_Thread_Local_Storage, 622 Aspect_Type_Invariant => Aspect_Invariant, 623 Aspect_Unchecked_Union => Aspect_Unchecked_Union, 624 Aspect_Unimplemented => Aspect_Unimplemented, 625 Aspect_Universal_Aliasing => Aspect_Universal_Aliasing, 626 Aspect_Universal_Data => Aspect_Universal_Data, 627 Aspect_Unmodified => Aspect_Unmodified, 628 Aspect_Unreferenced => Aspect_Unreferenced, 629 Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects, 630 Aspect_Unsuppress => Aspect_Unsuppress, 631 Aspect_Variable_Indexing => Aspect_Variable_Indexing, 632 Aspect_Value_Size => Aspect_Value_Size, 633 Aspect_Volatile => Aspect_Volatile, 634 Aspect_Volatile_Components => Aspect_Volatile_Components, 635 Aspect_Volatile_Full_Access => Aspect_Volatile_Full_Access, 636 Aspect_Volatile_Function => Aspect_Volatile_Function, 637 Aspect_Warnings => Aspect_Warnings, 638 Aspect_Write => Aspect_Write); 639 640 function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is 641 begin 642 return Canonical_Aspect (A1) = Canonical_Aspect (A2); 643 end Same_Aspect; 644 645 ------------------------------- 646 -- Set_Aspect_Specifications -- 647 ------------------------------- 648 649 procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is 650 begin 651 pragma Assert (Permits_Aspect_Specifications (N)); 652 pragma Assert (not Has_Aspects (N)); 653 pragma Assert (L /= No_List); 654 655 Set_Has_Aspects (N); 656 Set_Parent (L, N); 657 Aspect_Specifications_Hash_Table.Set (N, L); 658 end Set_Aspect_Specifications; 659 660 ---------------------------------------- 661 -- Set_Aspect_Specifications_No_Check -- 662 ---------------------------------------- 663 664 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is 665 begin 666 pragma Assert (Permits_Aspect_Specifications (N)); 667 pragma Assert (L /= No_List); 668 669 Set_Has_Aspects (N); 670 Set_Parent (L, N); 671 Aspect_Specifications_Hash_Table.Set (N, L); 672 end Set_Aspect_Specifications_No_Check; 673 674 --------------- 675 -- Tree_Read -- 676 --------------- 677 678 procedure Tree_Read is 679 Node : Node_Id; 680 List : List_Id; 681 begin 682 loop 683 Tree_Read_Int (Int (Node)); 684 Tree_Read_Int (Int (List)); 685 exit when List = No_List; 686 Set_Aspect_Specifications_No_Check (Node, List); 687 end loop; 688 end Tree_Read; 689 690 ---------------- 691 -- Tree_Write -- 692 ---------------- 693 694 procedure Tree_Write is 695 Node : Node_Id := Empty; 696 List : List_Id; 697 begin 698 Aspect_Specifications_Hash_Table.Get_First (Node, List); 699 loop 700 Tree_Write_Int (Int (Node)); 701 Tree_Write_Int (Int (List)); 702 exit when List = No_List; 703 Aspect_Specifications_Hash_Table.Get_Next (Node, List); 704 end loop; 705 end Tree_Write; 706 707-- Package initialization sets up Aspect Id hash table 708 709begin 710 for J in Aspect_Id loop 711 Aspect_Id_Hash_Table.Set (Aspect_Names (J), J); 712 end loop; 713end Aspects; 714