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
;
147 function Find_Aspect
(Id
: Entity_Id
; A
: Aspect_Id
) return Node_Id
is
156 -- Handle various cases of base or inherited aspects for types
159 if Base_Aspect
(A
) then
160 Owner
:= Base_Type
(Owner
);
163 if Is_Class_Wide_Type
(Owner
) and then Inherited_Aspect
(A
) then
164 Owner
:= Root_Type
(Owner
);
167 if Is_Private_Type
(Owner
) and then Present
(Full_View
(Owner
)) then
168 Owner
:= Full_View
(Owner
);
172 -- Search the representation items for the desired aspect
174 Item
:= First_Rep_Item
(Owner
);
175 while Present
(Item
) loop
176 if Nkind
(Item
) = N_Aspect_Specification
177 and then Get_Aspect_Id
(Item
) = A
182 Next_Rep_Item
(Item
);
185 -- Note that not all aspects are added to the chain of representation
186 -- items. In such cases, search the list of aspect specifications. First
187 -- find the declaration node where the aspects reside. This is usually
188 -- the parent or the parent of the parent.
190 Decl
:= Parent
(Owner
);
191 if not Permits_Aspect_Specifications
(Decl
) then
192 Decl
:= Parent
(Decl
);
195 -- Search the list of aspect specifications for the desired aspect
197 if Permits_Aspect_Specifications
(Decl
) then
198 Spec
:= First
(Aspect_Specifications
(Decl
));
199 while Present
(Spec
) loop
200 if Get_Aspect_Id
(Spec
) = A
then
208 -- The entity does not carry any aspects or the desired aspect was not
214 --------------------------
215 -- Find_Value_Of_Aspect --
216 --------------------------
218 function Find_Value_Of_Aspect
220 A
: Aspect_Id
) return Node_Id
222 Spec
: constant Node_Id
:= Find_Aspect
(Id
, A
);
225 if Present
(Spec
) then
226 if A
= Aspect_Default_Iterator
then
227 return Expression
(Aspect_Rep_Item
(Spec
));
229 return Expression
(Spec
);
234 end Find_Value_Of_Aspect
;
240 function Get_Aspect_Id
(Name
: Name_Id
) return Aspect_Id
is
242 return Aspect_Id_Hash_Table
.Get
(Name
);
245 function Get_Aspect_Id
(Aspect
: Node_Id
) return Aspect_Id
is
247 pragma Assert
(Nkind
(Aspect
) = N_Aspect_Specification
);
248 return Aspect_Id_Hash_Table
.Get
(Chars
(Identifier
(Aspect
)));
255 function Has_Aspect
(Id
: Entity_Id
; A
: Aspect_Id
) return Boolean is
257 return Present
(Find_Aspect
(Id
, A
));
264 procedure Move_Aspects
(From
: Node_Id
; To
: Node_Id
) is
265 pragma Assert
(not Has_Aspects
(To
));
267 if Has_Aspects
(From
) then
268 Set_Aspect_Specifications
(To
, Aspect_Specifications
(From
));
269 Aspect_Specifications_Hash_Table
.Remove
(From
);
270 Set_Has_Aspects
(From
, False);
274 -----------------------------------
275 -- Permits_Aspect_Specifications --
276 -----------------------------------
278 Has_Aspect_Specifications_Flag
: constant array (Node_Kind
) of Boolean :=
279 (N_Abstract_Subprogram_Declaration
=> True,
280 N_Component_Declaration
=> True,
281 N_Entry_Declaration
=> True,
282 N_Exception_Declaration
=> True,
283 N_Exception_Renaming_Declaration
=> True,
284 N_Expression_Function
=> True,
285 N_Formal_Abstract_Subprogram_Declaration
=> True,
286 N_Formal_Concrete_Subprogram_Declaration
=> True,
287 N_Formal_Object_Declaration
=> True,
288 N_Formal_Package_Declaration
=> True,
289 N_Formal_Type_Declaration
=> True,
290 N_Full_Type_Declaration
=> True,
291 N_Function_Instantiation
=> True,
292 N_Generic_Package_Declaration
=> True,
293 N_Generic_Renaming_Declaration
=> True,
294 N_Generic_Subprogram_Declaration
=> True,
295 N_Object_Declaration
=> True,
296 N_Object_Renaming_Declaration
=> True,
297 N_Package_Declaration
=> True,
298 N_Package_Instantiation
=> True,
299 N_Package_Specification
=> True,
300 N_Package_Renaming_Declaration
=> True,
301 N_Private_Extension_Declaration
=> True,
302 N_Private_Type_Declaration
=> True,
303 N_Procedure_Instantiation
=> True,
304 N_Protected_Body
=> True,
305 N_Protected_Type_Declaration
=> True,
306 N_Single_Protected_Declaration
=> True,
307 N_Single_Task_Declaration
=> True,
308 N_Subprogram_Body
=> True,
309 N_Subprogram_Declaration
=> True,
310 N_Subprogram_Renaming_Declaration
=> True,
311 N_Subprogram_Body_Stub
=> True,
312 N_Subtype_Declaration
=> True,
314 N_Task_Type_Declaration
=> True,
317 function Permits_Aspect_Specifications
(N
: Node_Id
) return Boolean is
319 return Has_Aspect_Specifications_Flag
(Nkind
(N
));
320 end Permits_Aspect_Specifications
;
326 -- Table used for Same_Aspect, maps aspect to canonical aspect
328 Canonical_Aspect
: constant array (Aspect_Id
) of Aspect_Id
:=
329 (No_Aspect
=> No_Aspect
,
330 Aspect_Abstract_State
=> Aspect_Abstract_State
,
331 Aspect_Ada_2005
=> Aspect_Ada_2005
,
332 Aspect_Ada_2012
=> Aspect_Ada_2005
,
333 Aspect_Address
=> Aspect_Address
,
334 Aspect_Alignment
=> Aspect_Alignment
,
335 Aspect_All_Calls_Remote
=> Aspect_All_Calls_Remote
,
336 Aspect_Asynchronous
=> Aspect_Asynchronous
,
337 Aspect_Atomic
=> Aspect_Atomic
,
338 Aspect_Atomic_Components
=> Aspect_Atomic_Components
,
339 Aspect_Attach_Handler
=> Aspect_Attach_Handler
,
340 Aspect_Bit_Order
=> Aspect_Bit_Order
,
341 Aspect_Compiler_Unit
=> Aspect_Compiler_Unit
,
342 Aspect_Component_Size
=> Aspect_Component_Size
,
343 Aspect_Constant_Indexing
=> Aspect_Constant_Indexing
,
344 Aspect_Contract_Cases
=> Aspect_Contract_Cases
,
345 Aspect_Convention
=> Aspect_Convention
,
346 Aspect_CPU
=> Aspect_CPU
,
347 Aspect_Default_Component_Value
=> Aspect_Default_Component_Value
,
348 Aspect_Default_Iterator
=> Aspect_Default_Iterator
,
349 Aspect_Default_Value
=> Aspect_Default_Value
,
350 Aspect_Depends
=> Aspect_Depends
,
351 Aspect_Dimension
=> Aspect_Dimension
,
352 Aspect_Dimension_System
=> Aspect_Dimension_System
,
353 Aspect_Discard_Names
=> Aspect_Discard_Names
,
354 Aspect_Dispatching_Domain
=> Aspect_Dispatching_Domain
,
355 Aspect_Dynamic_Predicate
=> Aspect_Predicate
,
356 Aspect_Elaborate_Body
=> Aspect_Elaborate_Body
,
357 Aspect_Export
=> Aspect_Export
,
358 Aspect_External_Name
=> Aspect_External_Name
,
359 Aspect_External_Tag
=> Aspect_External_Tag
,
360 Aspect_Favor_Top_Level
=> Aspect_Favor_Top_Level
,
361 Aspect_Global
=> Aspect_Global
,
362 Aspect_Implicit_Dereference
=> Aspect_Implicit_Dereference
,
363 Aspect_Import
=> Aspect_Import
,
364 Aspect_Independent
=> Aspect_Independent
,
365 Aspect_Independent_Components
=> Aspect_Independent_Components
,
366 Aspect_Inline
=> Aspect_Inline
,
367 Aspect_Inline_Always
=> Aspect_Inline
,
368 Aspect_Input
=> Aspect_Input
,
369 Aspect_Interrupt_Handler
=> Aspect_Interrupt_Handler
,
370 Aspect_Interrupt_Priority
=> Aspect_Priority
,
371 Aspect_Invariant
=> Aspect_Invariant
,
372 Aspect_Iterator_Element
=> Aspect_Iterator_Element
,
373 Aspect_Link_Name
=> Aspect_Link_Name
,
374 Aspect_Lock_Free
=> Aspect_Lock_Free
,
375 Aspect_Machine_Radix
=> Aspect_Machine_Radix
,
376 Aspect_No_Return
=> Aspect_No_Return
,
377 Aspect_Object_Size
=> Aspect_Object_Size
,
378 Aspect_Output
=> Aspect_Output
,
379 Aspect_Pack
=> Aspect_Pack
,
380 Aspect_Persistent_BSS
=> Aspect_Persistent_BSS
,
381 Aspect_Post
=> Aspect_Post
,
382 Aspect_Postcondition
=> Aspect_Post
,
383 Aspect_Pre
=> Aspect_Pre
,
384 Aspect_Precondition
=> Aspect_Pre
,
385 Aspect_Predicate
=> Aspect_Predicate
,
386 Aspect_Preelaborate
=> Aspect_Preelaborate
,
387 Aspect_Preelaborate_05
=> Aspect_Preelaborate_05
,
388 Aspect_Preelaborable_Initialization
=> Aspect_Preelaborable_Initialization
,
389 Aspect_Priority
=> Aspect_Priority
,
390 Aspect_Pure
=> Aspect_Pure
,
391 Aspect_Pure_05
=> Aspect_Pure_05
,
392 Aspect_Pure_12
=> Aspect_Pure_12
,
393 Aspect_Pure_Function
=> Aspect_Pure_Function
,
394 Aspect_Remote_Access_Type
=> Aspect_Remote_Access_Type
,
395 Aspect_Remote_Call_Interface
=> Aspect_Remote_Call_Interface
,
396 Aspect_Remote_Types
=> Aspect_Remote_Types
,
397 Aspect_Read
=> Aspect_Read
,
398 Aspect_Relative_Deadline
=> Aspect_Relative_Deadline
,
399 Aspect_Scalar_Storage_Order
=> Aspect_Scalar_Storage_Order
,
400 Aspect_Shared
=> Aspect_Atomic
,
401 Aspect_Shared_Passive
=> Aspect_Shared_Passive
,
402 Aspect_Simple_Storage_Pool
=> Aspect_Simple_Storage_Pool
,
403 Aspect_Simple_Storage_Pool_Type
=> Aspect_Simple_Storage_Pool_Type
,
404 Aspect_Size
=> Aspect_Size
,
405 Aspect_Small
=> Aspect_Small
,
406 Aspect_SPARK_Mode
=> Aspect_SPARK_Mode
,
407 Aspect_Static_Predicate
=> Aspect_Predicate
,
408 Aspect_Storage_Pool
=> Aspect_Storage_Pool
,
409 Aspect_Storage_Size
=> Aspect_Storage_Size
,
410 Aspect_Stream_Size
=> Aspect_Stream_Size
,
411 Aspect_Suppress
=> Aspect_Suppress
,
412 Aspect_Suppress_Debug_Info
=> Aspect_Suppress_Debug_Info
,
413 Aspect_Synchronization
=> Aspect_Synchronization
,
414 Aspect_Test_Case
=> Aspect_Test_Case
,
415 Aspect_Type_Invariant
=> Aspect_Invariant
,
416 Aspect_Unchecked_Union
=> Aspect_Unchecked_Union
,
417 Aspect_Universal_Aliasing
=> Aspect_Universal_Aliasing
,
418 Aspect_Universal_Data
=> Aspect_Universal_Data
,
419 Aspect_Unmodified
=> Aspect_Unmodified
,
420 Aspect_Unreferenced
=> Aspect_Unreferenced
,
421 Aspect_Unreferenced_Objects
=> Aspect_Unreferenced_Objects
,
422 Aspect_Unsuppress
=> Aspect_Unsuppress
,
423 Aspect_Variable_Indexing
=> Aspect_Variable_Indexing
,
424 Aspect_Value_Size
=> Aspect_Value_Size
,
425 Aspect_Volatile
=> Aspect_Volatile
,
426 Aspect_Volatile_Components
=> Aspect_Volatile_Components
,
427 Aspect_Warnings
=> Aspect_Warnings
,
428 Aspect_Write
=> Aspect_Write
);
430 function Same_Aspect
(A1
: Aspect_Id
; A2
: Aspect_Id
) return Boolean is
432 return Canonical_Aspect
(A1
) = Canonical_Aspect
(A2
);
435 -------------------------------
436 -- Set_Aspect_Specifications --
437 -------------------------------
439 procedure Set_Aspect_Specifications
(N
: Node_Id
; L
: List_Id
) is
441 pragma Assert
(Permits_Aspect_Specifications
(N
));
442 pragma Assert
(not Has_Aspects
(N
));
443 pragma Assert
(L
/= No_List
);
447 Aspect_Specifications_Hash_Table
.Set
(N
, L
);
448 end Set_Aspect_Specifications
;
450 ----------------------------------------
451 -- Set_Aspect_Specifications_No_Check --
452 ----------------------------------------
454 procedure Set_Aspect_Specifications_No_Check
(N
: Node_Id
; L
: List_Id
) is
456 pragma Assert
(Permits_Aspect_Specifications
(N
));
457 pragma Assert
(L
/= No_List
);
461 Aspect_Specifications_Hash_Table
.Set
(N
, L
);
462 end Set_Aspect_Specifications_No_Check
;
468 procedure Tree_Read
is
473 Tree_Read_Int
(Int
(Node
));
474 Tree_Read_Int
(Int
(List
));
475 exit when List
= No_List
;
476 Set_Aspect_Specifications_No_Check
(Node
, List
);
484 procedure Tree_Write
is
485 Node
: Node_Id
:= Empty
;
488 Aspect_Specifications_Hash_Table
.Get_First
(Node
, List
);
490 Tree_Write_Int
(Int
(Node
));
491 Tree_Write_Int
(Int
(List
));
492 exit when List
= No_List
;
493 Aspect_Specifications_Hash_Table
.Get_Next
(Node
, List
);
497 -- Package initialization sets up Aspect Id hash table
500 for J
in Aspect_Id
loop
501 Aspect_Id_Hash_Table
.Set
(Aspect_Names
(J
), J
);