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