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_Iterable
=> Aspect_Iterable
,
518 Aspect_Iterator_Element
=> Aspect_Iterator_Element
,
519 Aspect_Link_Name
=> Aspect_Link_Name
,
520 Aspect_Linker_Section
=> Aspect_Linker_Section
,
521 Aspect_Lock_Free
=> Aspect_Lock_Free
,
522 Aspect_Machine_Radix
=> Aspect_Machine_Radix
,
523 Aspect_No_Return
=> Aspect_No_Return
,
524 Aspect_Object_Size
=> Aspect_Object_Size
,
525 Aspect_Output
=> Aspect_Output
,
526 Aspect_Pack
=> Aspect_Pack
,
527 Aspect_Part_Of
=> Aspect_Part_Of
,
528 Aspect_Persistent_BSS
=> Aspect_Persistent_BSS
,
529 Aspect_Post
=> Aspect_Post
,
530 Aspect_Postcondition
=> Aspect_Post
,
531 Aspect_Pre
=> Aspect_Pre
,
532 Aspect_Precondition
=> Aspect_Pre
,
533 Aspect_Predicate
=> Aspect_Predicate
,
534 Aspect_Preelaborate
=> Aspect_Preelaborate
,
535 Aspect_Preelaborate_05
=> Aspect_Preelaborate_05
,
536 Aspect_Preelaborable_Initialization
=> Aspect_Preelaborable_Initialization
,
537 Aspect_Priority
=> Aspect_Priority
,
538 Aspect_Pure
=> Aspect_Pure
,
539 Aspect_Pure_05
=> Aspect_Pure_05
,
540 Aspect_Pure_12
=> Aspect_Pure_12
,
541 Aspect_Pure_Function
=> Aspect_Pure_Function
,
542 Aspect_Refined_Depends
=> Aspect_Refined_Depends
,
543 Aspect_Refined_Global
=> Aspect_Refined_Global
,
544 Aspect_Refined_Post
=> Aspect_Refined_Post
,
545 Aspect_Refined_State
=> Aspect_Refined_State
,
546 Aspect_Remote_Access_Type
=> Aspect_Remote_Access_Type
,
547 Aspect_Remote_Call_Interface
=> Aspect_Remote_Call_Interface
,
548 Aspect_Remote_Types
=> Aspect_Remote_Types
,
549 Aspect_Read
=> Aspect_Read
,
550 Aspect_Relative_Deadline
=> Aspect_Relative_Deadline
,
551 Aspect_Scalar_Storage_Order
=> Aspect_Scalar_Storage_Order
,
552 Aspect_Shared
=> Aspect_Atomic
,
553 Aspect_Shared_Passive
=> Aspect_Shared_Passive
,
554 Aspect_Simple_Storage_Pool
=> Aspect_Simple_Storage_Pool
,
555 Aspect_Simple_Storage_Pool_Type
=> Aspect_Simple_Storage_Pool_Type
,
556 Aspect_Size
=> Aspect_Size
,
557 Aspect_Small
=> Aspect_Small
,
558 Aspect_SPARK_Mode
=> Aspect_SPARK_Mode
,
559 Aspect_Static_Predicate
=> Aspect_Predicate
,
560 Aspect_Storage_Pool
=> Aspect_Storage_Pool
,
561 Aspect_Storage_Size
=> Aspect_Storage_Size
,
562 Aspect_Stream_Size
=> Aspect_Stream_Size
,
563 Aspect_Suppress
=> Aspect_Suppress
,
564 Aspect_Suppress_Debug_Info
=> Aspect_Suppress_Debug_Info
,
565 Aspect_Synchronization
=> Aspect_Synchronization
,
566 Aspect_Test_Case
=> Aspect_Test_Case
,
567 Aspect_Type_Invariant
=> Aspect_Invariant
,
568 Aspect_Unchecked_Union
=> Aspect_Unchecked_Union
,
569 Aspect_Universal_Aliasing
=> Aspect_Universal_Aliasing
,
570 Aspect_Universal_Data
=> Aspect_Universal_Data
,
571 Aspect_Unmodified
=> Aspect_Unmodified
,
572 Aspect_Unreferenced
=> Aspect_Unreferenced
,
573 Aspect_Unreferenced_Objects
=> Aspect_Unreferenced_Objects
,
574 Aspect_Unsuppress
=> Aspect_Unsuppress
,
575 Aspect_Variable_Indexing
=> Aspect_Variable_Indexing
,
576 Aspect_Value_Size
=> Aspect_Value_Size
,
577 Aspect_Volatile
=> Aspect_Volatile
,
578 Aspect_Volatile_Components
=> Aspect_Volatile_Components
,
579 Aspect_Warnings
=> Aspect_Warnings
,
580 Aspect_Write
=> Aspect_Write
);
582 function Same_Aspect
(A1
: Aspect_Id
; A2
: Aspect_Id
) return Boolean is
584 return Canonical_Aspect
(A1
) = Canonical_Aspect
(A2
);
587 -------------------------------
588 -- Set_Aspect_Specifications --
589 -------------------------------
591 procedure Set_Aspect_Specifications
(N
: Node_Id
; L
: List_Id
) is
593 pragma Assert
(Permits_Aspect_Specifications
(N
));
594 pragma Assert
(not Has_Aspects
(N
));
595 pragma Assert
(L
/= No_List
);
599 Aspect_Specifications_Hash_Table
.Set
(N
, L
);
600 end Set_Aspect_Specifications
;
602 ----------------------------------------
603 -- Set_Aspect_Specifications_No_Check --
604 ----------------------------------------
606 procedure Set_Aspect_Specifications_No_Check
(N
: Node_Id
; L
: List_Id
) is
608 pragma Assert
(Permits_Aspect_Specifications
(N
));
609 pragma Assert
(L
/= No_List
);
613 Aspect_Specifications_Hash_Table
.Set
(N
, L
);
614 end Set_Aspect_Specifications_No_Check
;
620 procedure Tree_Read
is
625 Tree_Read_Int
(Int
(Node
));
626 Tree_Read_Int
(Int
(List
));
627 exit when List
= No_List
;
628 Set_Aspect_Specifications_No_Check
(Node
, List
);
636 procedure Tree_Write
is
637 Node
: Node_Id
:= Empty
;
640 Aspect_Specifications_Hash_Table
.Get_First
(Node
, List
);
642 Tree_Write_Int
(Int
(Node
));
643 Tree_Write_Int
(Int
(List
));
644 exit when List
= No_List
;
645 Aspect_Specifications_Hash_Table
.Get_Next
(Node
, List
);
649 -- Package initialization sets up Aspect Id hash table
652 for J
in Aspect_Id
loop
653 Aspect_Id_Hash_Table
.Set
(Aspect_Names
(J
), J
);