1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2010-2013, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
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;
38 with GNAT.HTable; use GNAT.HTable;
40 package body Aspects is
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.
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,
60 -- The following array indicates type aspects that are inherited and apply
61 -- to the class-wide type as well.
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,
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.
82 ------------------------------------------
83 -- Hash Table for Aspect Specifications --
84 ------------------------------------------
86 type AS_Hash_Range is range 0 .. 510;
87 -- Size of hash table headers
89 function AS_Hash (F : Node_Id) return AS_Hash_Range;
90 -- Hash function for hash table
92 function AS_Hash (F : Node_Id) return AS_Hash_Range is
94 return AS_Hash_Range (F mod 511);
97 package Aspect_Specifications_Hash_Table is new
98 GNAT.HTable.Simple_HTable
99 (Header_Num => AS_Hash_Range,
101 No_Element => No_List,
106 -------------------------------------
107 -- Hash Table for Aspect Id Values --
108 -------------------------------------
110 type AI_Hash_Range is range 0 .. 112;
111 -- Size of hash table headers
113 function AI_Hash (F : Name_Id) return AI_Hash_Range;
114 -- Hash function for hash table
116 function AI_Hash (F : Name_Id) return AI_Hash_Range is
118 return AI_Hash_Range (F mod 113);
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,
130 ---------------------------
131 -- Aspect_Specifications --
132 ---------------------------
134 function Aspect_Specifications (N : Node_Id) return List_Id is
136 if Has_Aspects (N) then
137 return Aspect_Specifications_Hash_Table.Get (N);
141 end Aspect_Specifications;
143 --------------------------------
144 -- Aspects_On_Body_Or_Stub_OK --
145 --------------------------------
147 function Aspects_On_Body_Or_Stub_OK (N : Node_Id) return Boolean is
152 -- The routine should be invoked on a body [stub] with aspects
154 pragma Assert (Has_Aspects (N));
155 pragma Assert (Nkind (N) in N_Body_Stub
156 or else Nkind_In (N, N_Package_Body,
161 -- Look through all aspects and see whether they can be applied to a
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
175 end Aspects_On_Body_Or_Stub_OK;
181 function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id is
190 -- Handle various cases of base or inherited aspects for types
193 if Base_Aspect (A) then
194 Owner := Base_Type (Owner);
197 if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then
198 Owner := Root_Type (Owner);
201 if Is_Private_Type (Owner) and then Present (Full_View (Owner)) then
202 Owner := Full_View (Owner);
206 -- Search the representation items for the desired aspect
208 Item := First_Rep_Item (Owner);
209 while Present (Item) loop
210 if Nkind (Item) = N_Aspect_Specification
211 and then Get_Aspect_Id (Item) = A
216 Next_Rep_Item (Item);
219 -- Note that not all aspects are added to the chain of representation
220 -- items. In such cases, search the list of aspect specifications. First
221 -- find the declaration node where the aspects reside. This is usually
222 -- the parent or the parent of the parent.
224 Decl := Parent (Owner);
225 if not Permits_Aspect_Specifications (Decl) then
226 Decl := Parent (Decl);
229 -- Search the list of aspect specifications for the desired aspect
231 if Permits_Aspect_Specifications (Decl) then
232 Spec := First (Aspect_Specifications (Decl));
233 while Present (Spec) loop
234 if Get_Aspect_Id (Spec) = A then
242 -- The entity does not carry any aspects or the desired aspect was not
248 --------------------------
249 -- Find_Value_Of_Aspect --
250 --------------------------
252 function Find_Value_Of_Aspect
254 A : Aspect_Id) return Node_Id
256 Spec : constant Node_Id := Find_Aspect (Id, A);
259 if Present (Spec) then
260 if A = Aspect_Default_Iterator then
261 return Expression (Aspect_Rep_Item (Spec));
263 return Expression (Spec);
268 end Find_Value_Of_Aspect;
274 function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
276 return Aspect_Id_Hash_Table.Get (Name);
279 function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is
281 pragma Assert (Nkind (Aspect) = N_Aspect_Specification);
282 return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect)));
289 function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is
291 return Present (Find_Aspect (Id, A));
298 procedure Move_Aspects (From : Node_Id; To : Node_Id) is
299 pragma Assert (not Has_Aspects (To));
301 if Has_Aspects (From) then
302 Set_Aspect_Specifications (To, Aspect_Specifications (From));
303 Aspect_Specifications_Hash_Table.Remove (From);
304 Set_Has_Aspects (From, False);
308 ---------------------------
309 -- Move_Or_Merge_Aspects --
310 ---------------------------
312 procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is
313 procedure Relocate_Aspect (Asp : Node_Id);
314 -- Asp denotes an aspect specification of node From. Relocate the Asp to
315 -- the aspect specifications of node To (if any).
317 ---------------------
318 -- Relocate_Aspect --
319 ---------------------
321 procedure Relocate_Aspect (Asp : Node_Id) is
325 if Has_Aspects (To) then
326 Asps := Aspect_Specifications (To);
328 -- Create a new aspect specification list for node To
332 Set_Aspect_Specifications (To, Asps);
333 Set_Has_Aspects (To);
336 -- Remove the aspect from node From's aspect specifications and
337 -- append it to node To.
349 -- Start of processing for Move_Or_Merge_Aspects
352 if Has_Aspects (From) then
353 Asp := First (Aspect_Specifications (From));
354 while Present (Asp) loop
356 -- Store the next aspect now as a potential relocation will alter
357 -- the contents of the list.
359 Next_Asp := Next (Asp);
361 -- When moving or merging aspects from a subprogram body stub that
362 -- also acts as a spec, relocate only those aspects that may apply
363 -- to a body [stub]. Note that a precondition must also be moved
364 -- to the proper body as the pre/post machinery expects it to be
367 if Nkind (From) = N_Subprogram_Body_Stub
368 and then No (Corresponding_Spec_Of_Stub (From))
370 Asp_Id := Get_Aspect_Id (Asp);
372 if Aspect_On_Body_Or_Stub_OK (Asp_Id)
373 or else Asp_Id = Aspect_Pre
374 or else Asp_Id = Aspect_Precondition
376 Relocate_Aspect (Asp);
379 -- Default case - relocate the aspect to its new owner
382 Relocate_Aspect (Asp);
388 -- The relocations may have left node From's aspect specifications
389 -- list empty. If this is the case, simply remove the aspects.
391 if Is_Empty_List (Aspect_Specifications (From)) then
392 Remove_Aspects (From);
395 end Move_Or_Merge_Aspects;
397 -----------------------------------
398 -- Permits_Aspect_Specifications --
399 -----------------------------------
401 Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
402 (N_Abstract_Subprogram_Declaration => True,
403 N_Component_Declaration => True,
404 N_Entry_Declaration => True,
405 N_Exception_Declaration => True,
406 N_Exception_Renaming_Declaration => True,
407 N_Expression_Function => True,
408 N_Formal_Abstract_Subprogram_Declaration => True,
409 N_Formal_Concrete_Subprogram_Declaration => True,
410 N_Formal_Object_Declaration => True,
411 N_Formal_Package_Declaration => True,
412 N_Formal_Type_Declaration => True,
413 N_Full_Type_Declaration => True,
414 N_Function_Instantiation => True,
415 N_Generic_Package_Declaration => True,
416 N_Generic_Renaming_Declaration => True,
417 N_Generic_Subprogram_Declaration => True,
418 N_Object_Declaration => True,
419 N_Object_Renaming_Declaration => True,
420 N_Package_Body => True,
421 N_Package_Body_Stub => True,
422 N_Package_Declaration => True,
423 N_Package_Instantiation => True,
424 N_Package_Specification => True,
425 N_Package_Renaming_Declaration => True,
426 N_Private_Extension_Declaration => True,
427 N_Private_Type_Declaration => True,
428 N_Procedure_Instantiation => True,
429 N_Protected_Body => True,
430 N_Protected_Body_Stub => True,
431 N_Protected_Type_Declaration => True,
432 N_Single_Protected_Declaration => True,
433 N_Single_Task_Declaration => True,
434 N_Subprogram_Body => True,
435 N_Subprogram_Body_Stub => True,
436 N_Subprogram_Declaration => True,
437 N_Subprogram_Renaming_Declaration => True,
438 N_Subtype_Declaration => True,
440 N_Task_Body_Stub => True,
441 N_Task_Type_Declaration => True,
444 function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
446 return Has_Aspect_Specifications_Flag (Nkind (N));
447 end Permits_Aspect_Specifications;
453 procedure Remove_Aspects (N : Node_Id) is
455 if Has_Aspects (N) then
456 Aspect_Specifications_Hash_Table.Remove (N);
457 Set_Has_Aspects (N, False);
465 -- Table used for Same_Aspect, maps aspect to canonical aspect
467 Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
468 (No_Aspect => No_Aspect,
469 Aspect_Abstract_State => Aspect_Abstract_State,
470 Aspect_Ada_2005 => Aspect_Ada_2005,
471 Aspect_Ada_2012 => Aspect_Ada_2005,
472 Aspect_Address => Aspect_Address,
473 Aspect_Alignment => Aspect_Alignment,
474 Aspect_All_Calls_Remote => Aspect_All_Calls_Remote,
475 Aspect_Async_Readers => Aspect_Async_Readers,
476 Aspect_Async_Writers => Aspect_Async_Writers,
477 Aspect_Asynchronous => Aspect_Asynchronous,
478 Aspect_Atomic => Aspect_Atomic,
479 Aspect_Atomic_Components => Aspect_Atomic_Components,
480 Aspect_Attach_Handler => Aspect_Attach_Handler,
481 Aspect_Bit_Order => Aspect_Bit_Order,
482 Aspect_Compiler_Unit => Aspect_Compiler_Unit,
483 Aspect_Component_Size => Aspect_Component_Size,
484 Aspect_Constant_Indexing => Aspect_Constant_Indexing,
485 Aspect_Contract_Cases => Aspect_Contract_Cases,
486 Aspect_Convention => Aspect_Convention,
487 Aspect_CPU => Aspect_CPU,
488 Aspect_Default_Component_Value => Aspect_Default_Component_Value,
489 Aspect_Default_Iterator => Aspect_Default_Iterator,
490 Aspect_Default_Value => Aspect_Default_Value,
491 Aspect_Depends => Aspect_Depends,
492 Aspect_Dimension => Aspect_Dimension,
493 Aspect_Dimension_System => Aspect_Dimension_System,
494 Aspect_Discard_Names => Aspect_Discard_Names,
495 Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
496 Aspect_Dynamic_Predicate => Aspect_Predicate,
497 Aspect_Effective_Reads => Aspect_Effective_Reads,
498 Aspect_Effective_Writes => Aspect_Effective_Writes,
499 Aspect_Elaborate_Body => Aspect_Elaborate_Body,
500 Aspect_Export => Aspect_Export,
501 Aspect_External_Name => Aspect_External_Name,
502 Aspect_External_Tag => Aspect_External_Tag,
503 Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
504 Aspect_Global => Aspect_Global,
505 Aspect_Implicit_Dereference => Aspect_Implicit_Dereference,
506 Aspect_Import => Aspect_Import,
507 Aspect_Independent => Aspect_Independent,
508 Aspect_Independent_Components => Aspect_Independent_Components,
509 Aspect_Inline => Aspect_Inline,
510 Aspect_Inline_Always => Aspect_Inline,
511 Aspect_Initial_Condition => Aspect_Initial_Condition,
512 Aspect_Initializes => Aspect_Initializes,
513 Aspect_Input => Aspect_Input,
514 Aspect_Interrupt_Handler => Aspect_Interrupt_Handler,
515 Aspect_Interrupt_Priority => Aspect_Priority,
516 Aspect_Invariant => Aspect_Invariant,
517 Aspect_Iterator_Element => Aspect_Iterator_Element,
518 Aspect_Link_Name => Aspect_Link_Name,
519 Aspect_Lock_Free => Aspect_Lock_Free,
520 Aspect_Machine_Radix => Aspect_Machine_Radix,
521 Aspect_No_Return => Aspect_No_Return,
522 Aspect_Object_Size => Aspect_Object_Size,
523 Aspect_Output => Aspect_Output,
524 Aspect_Pack => Aspect_Pack,
525 Aspect_Persistent_BSS => Aspect_Persistent_BSS,
526 Aspect_Post => Aspect_Post,
527 Aspect_Postcondition => Aspect_Post,
528 Aspect_Pre => Aspect_Pre,
529 Aspect_Precondition => Aspect_Pre,
530 Aspect_Predicate => Aspect_Predicate,
531 Aspect_Preelaborate => Aspect_Preelaborate,
532 Aspect_Preelaborate_05 => Aspect_Preelaborate_05,
533 Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
534 Aspect_Priority => Aspect_Priority,
535 Aspect_Pure => Aspect_Pure,
536 Aspect_Pure_05 => Aspect_Pure_05,
537 Aspect_Pure_12 => Aspect_Pure_12,
538 Aspect_Pure_Function => Aspect_Pure_Function,
539 Aspect_Refined_Depends => Aspect_Refined_Depends,
540 Aspect_Refined_Global => Aspect_Refined_Global,
541 Aspect_Refined_Post => Aspect_Refined_Post,
542 Aspect_Refined_State => Aspect_Refined_State,
543 Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,
544 Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
545 Aspect_Remote_Types => Aspect_Remote_Types,
546 Aspect_Read => Aspect_Read,
547 Aspect_Relative_Deadline => Aspect_Relative_Deadline,
548 Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order,
549 Aspect_Shared => Aspect_Atomic,
550 Aspect_Shared_Passive => Aspect_Shared_Passive,
551 Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
552 Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type,
553 Aspect_Size => Aspect_Size,
554 Aspect_Small => Aspect_Small,
555 Aspect_SPARK_Mode => Aspect_SPARK_Mode,
556 Aspect_Static_Predicate => Aspect_Predicate,
557 Aspect_Storage_Pool => Aspect_Storage_Pool,
558 Aspect_Storage_Size => Aspect_Storage_Size,
559 Aspect_Stream_Size => Aspect_Stream_Size,
560 Aspect_Suppress => Aspect_Suppress,
561 Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info,
562 Aspect_Synchronization => Aspect_Synchronization,
563 Aspect_Test_Case => Aspect_Test_Case,
564 Aspect_Type_Invariant => Aspect_Invariant,
565 Aspect_Unchecked_Union => Aspect_Unchecked_Union,
566 Aspect_Universal_Aliasing => Aspect_Universal_Aliasing,
567 Aspect_Universal_Data => Aspect_Universal_Data,
568 Aspect_Unmodified => Aspect_Unmodified,
569 Aspect_Unreferenced => Aspect_Unreferenced,
570 Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects,
571 Aspect_Unsuppress => Aspect_Unsuppress,
572 Aspect_Variable_Indexing => Aspect_Variable_Indexing,
573 Aspect_Value_Size => Aspect_Value_Size,
574 Aspect_Volatile => Aspect_Volatile,
575 Aspect_Volatile_Components => Aspect_Volatile_Components,
576 Aspect_Warnings => Aspect_Warnings,
577 Aspect_Write => Aspect_Write);
579 function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
581 return Canonical_Aspect (A1) = Canonical_Aspect (A2);
584 -------------------------------
585 -- Set_Aspect_Specifications --
586 -------------------------------
588 procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
590 pragma Assert (Permits_Aspect_Specifications (N));
591 pragma Assert (not Has_Aspects (N));
592 pragma Assert (L /= No_List);
596 Aspect_Specifications_Hash_Table.Set (N, L);
597 end Set_Aspect_Specifications;
599 ----------------------------------------
600 -- Set_Aspect_Specifications_No_Check --
601 ----------------------------------------
603 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
605 pragma Assert (Permits_Aspect_Specifications (N));
606 pragma Assert (L /= No_List);
610 Aspect_Specifications_Hash_Table.Set (N, L);
611 end Set_Aspect_Specifications_No_Check;
617 procedure Tree_Read is
622 Tree_Read_Int (Int (Node));
623 Tree_Read_Int (Int (List));
624 exit when List = No_List;
625 Set_Aspect_Specifications_No_Check (Node, List);
633 procedure Tree_Write is
634 Node : Node_Id := Empty;
637 Aspect_Specifications_Hash_Table.Get_First (Node, List);
639 Tree_Write_Int (Int (Node));
640 Tree_Write_Int (Int (List));
641 exit when List = No_List;
642 Aspect_Specifications_Hash_Table.Get_Next (Node, List);
646 -- Package initialization sets up Aspect Id hash table
649 for J in Aspect_Id loop
650 Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);