File : aspects.adb
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 -- --
19 -- --
20 -- --
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
32 with Atree; use Atree;
33 with Einfo; use Einfo;
34 with Nlists; use Nlists;
35 with Sinfo; use Sinfo;
36 with Tree_IO; use Tree_IO;
37
38 with GNAT.HTable; use GNAT.HTable;
39
40 package 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_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
572 Aspect_No_Return => Aspect_No_Return,
573 Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams,
574 Aspect_Obsolescent => Aspect_Obsolescent,
575 Aspect_Object_Size => Aspect_Object_Size,
576 Aspect_Output => Aspect_Output,
577 Aspect_Pack => Aspect_Pack,
578 Aspect_Part_Of => Aspect_Part_Of,
579 Aspect_Persistent_BSS => Aspect_Persistent_BSS,
580 Aspect_Post => Aspect_Post,
581 Aspect_Postcondition => Aspect_Post,
582 Aspect_Pre => Aspect_Pre,
583 Aspect_Precondition => Aspect_Pre,
584 Aspect_Predicate => Aspect_Predicate,
585 Aspect_Predicate_Failure => Aspect_Predicate_Failure,
586 Aspect_Preelaborate => Aspect_Preelaborate,
587 Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
588 Aspect_Priority => Aspect_Priority,
589 Aspect_Pure => Aspect_Pure,
590 Aspect_Pure_Function => Aspect_Pure_Function,
591 Aspect_Refined_Depends => Aspect_Refined_Depends,
592 Aspect_Refined_Global => Aspect_Refined_Global,
593 Aspect_Refined_Post => Aspect_Refined_Post,
594 Aspect_Refined_State => Aspect_Refined_State,
595 Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,
596 Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
597 Aspect_Remote_Types => Aspect_Remote_Types,
598 Aspect_Read => Aspect_Read,
599 Aspect_Relative_Deadline => Aspect_Relative_Deadline,
600 Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order,
601 Aspect_Shared => Aspect_Atomic,
602 Aspect_Shared_Passive => Aspect_Shared_Passive,
603 Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
604 Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type,
605 Aspect_Size => Aspect_Size,
606 Aspect_Small => Aspect_Small,
607 Aspect_SPARK_Mode => Aspect_SPARK_Mode,
608 Aspect_Static_Predicate => Aspect_Predicate,
609 Aspect_Storage_Pool => Aspect_Storage_Pool,
610 Aspect_Storage_Size => Aspect_Storage_Size,
611 Aspect_Stream_Size => Aspect_Stream_Size,
612 Aspect_Suppress => Aspect_Suppress,
613 Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info,
614 Aspect_Suppress_Initialization => Aspect_Suppress_Initialization,
615 Aspect_Synchronization => Aspect_Synchronization,
616 Aspect_Test_Case => Aspect_Test_Case,
617 Aspect_Thread_Local_Storage => Aspect_Thread_Local_Storage,
618 Aspect_Type_Invariant => Aspect_Invariant,
619 Aspect_Unchecked_Union => Aspect_Unchecked_Union,
620 Aspect_Unimplemented => Aspect_Unimplemented,
621 Aspect_Universal_Aliasing => Aspect_Universal_Aliasing,
622 Aspect_Universal_Data => Aspect_Universal_Data,
623 Aspect_Unmodified => Aspect_Unmodified,
624 Aspect_Unreferenced => Aspect_Unreferenced,
625 Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects,
626 Aspect_Unsuppress => Aspect_Unsuppress,
627 Aspect_Variable_Indexing => Aspect_Variable_Indexing,
628 Aspect_Value_Size => Aspect_Value_Size,
629 Aspect_Volatile => Aspect_Volatile,
630 Aspect_Volatile_Components => Aspect_Volatile_Components,
631 Aspect_Volatile_Full_Access => Aspect_Volatile_Full_Access,
632 Aspect_Volatile_Function => Aspect_Volatile_Function,
633 Aspect_Warnings => Aspect_Warnings,
634 Aspect_Write => Aspect_Write);
635
636 function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
637 begin
638 return Canonical_Aspect (A1) = Canonical_Aspect (A2);
639 end Same_Aspect;
640
641 -------------------------------
642 -- Set_Aspect_Specifications --
643 -------------------------------
644
645 procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
646 begin
647 pragma Assert (Permits_Aspect_Specifications (N));
648 pragma Assert (not Has_Aspects (N));
649 pragma Assert (L /= No_List);
650
651 Set_Has_Aspects (N);
652 Set_Parent (L, N);
653 Aspect_Specifications_Hash_Table.Set (N, L);
654 end Set_Aspect_Specifications;
655
656 ----------------------------------------
657 -- Set_Aspect_Specifications_No_Check --
658 ----------------------------------------
659
660 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
661 begin
662 pragma Assert (Permits_Aspect_Specifications (N));
663 pragma Assert (L /= No_List);
664
665 Set_Has_Aspects (N);
666 Set_Parent (L, N);
667 Aspect_Specifications_Hash_Table.Set (N, L);
668 end Set_Aspect_Specifications_No_Check;
669
670 ---------------
671 -- Tree_Read --
672 ---------------
673
674 procedure Tree_Read is
675 Node : Node_Id;
676 List : List_Id;
677 begin
678 loop
679 Tree_Read_Int (Int (Node));
680 Tree_Read_Int (Int (List));
681 exit when List = No_List;
682 Set_Aspect_Specifications_No_Check (Node, List);
683 end loop;
684 end Tree_Read;
685
686 ----------------
687 -- Tree_Write --
688 ----------------
689
690 procedure Tree_Write is
691 Node : Node_Id := Empty;
692 List : List_Id;
693 begin
694 Aspect_Specifications_Hash_Table.Get_First (Node, List);
695 loop
696 Tree_Write_Int (Int (Node));
697 Tree_Write_Int (Int (List));
698 exit when List = No_List;
699 Aspect_Specifications_Hash_Table.Get_Next (Node, List);
700 end loop;
701 end Tree_Write;
702
703 -- Package initialization sets up Aspect Id hash table
704
705 begin
706 for J in Aspect_Id loop
707 Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
708 end loop;
709 end Aspects;