1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2010-2012, 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 procedure Set_Aspect_Specifications_No_Check
(N
: Node_Id
; L
: List_Id
);
43 -- Same as Set_Aspect_Specifications, but does not contain the assertion
44 -- that checks that N does not already have aspect specifications. This
45 -- subprogram is supposed to be used as a part of Tree_Read. When reading
46 -- tree, first read nodes with their basic properties (as Atree.Tree_Read),
47 -- this includes reading the Has_Aspects flag for each node, then we reed
48 -- all the list tables and only after that we call Tree_Read for Aspects.
49 -- That is, when reading the tree, the list of aspects is attached to the
50 -- node that already has Has_Aspects flag set ON.
52 ------------------------------------------
53 -- Hash Table for Aspect Specifications --
54 ------------------------------------------
56 type AS_Hash_Range
is range 0 .. 510;
57 -- Size of hash table headers
59 function AS_Hash
(F
: Node_Id
) return AS_Hash_Range
;
60 -- Hash function for hash table
62 function AS_Hash
(F
: Node_Id
) return AS_Hash_Range
is
64 return AS_Hash_Range
(F
mod 511);
67 package Aspect_Specifications_Hash_Table
is new
68 GNAT
.HTable
.Simple_HTable
69 (Header_Num
=> AS_Hash_Range
,
71 No_Element
=> No_List
,
76 -------------------------------------
77 -- Hash Table for Aspect Id Values --
78 -------------------------------------
80 type AI_Hash_Range
is range 0 .. 112;
81 -- Size of hash table headers
83 function AI_Hash
(F
: Name_Id
) return AI_Hash_Range
;
84 -- Hash function for hash table
86 function AI_Hash
(F
: Name_Id
) return AI_Hash_Range
is
88 return AI_Hash_Range
(F
mod 113);
91 package Aspect_Id_Hash_Table
is new
92 GNAT
.HTable
.Simple_HTable
93 (Header_Num
=> AI_Hash_Range
,
95 No_Element
=> No_Aspect
,
100 ---------------------------
101 -- Aspect_Specifications --
102 ---------------------------
104 function Aspect_Specifications
(N
: Node_Id
) return List_Id
is
106 if Has_Aspects
(N
) then
107 return Aspect_Specifications_Hash_Table
.Get
(N
);
111 end Aspect_Specifications
;
117 function Get_Aspect_Id
(Name
: Name_Id
) return Aspect_Id
is
119 return Aspect_Id_Hash_Table
.Get
(Name
);
126 function Find_Aspect
(Ent
: Entity_Id
; A
: Aspect_Id
) return Node_Id
is
132 -- If the aspect is an inherited one and the entity is a class-wide
133 -- type, use the aspect of the specific type. If the type is a base
134 -- aspect, examine the rep. items of the base type.
136 if Is_Type
(Ent
) then
137 if Base_Aspect
(A
) then
138 Typ
:= Base_Type
(Ent
);
143 if Is_Class_Wide_Type
(Typ
)
144 and then Inherited_Aspect
(A
)
146 Ritem
:= First_Rep_Item
(Etype
(Typ
));
148 Ritem
:= First_Rep_Item
(Typ
);
152 Ritem
:= First_Rep_Item
(Ent
);
155 while Present
(Ritem
) loop
156 if Nkind
(Ritem
) = N_Aspect_Specification
157 and then Get_Aspect_Id
(Chars
(Identifier
(Ritem
))) = A
159 if A
= Aspect_Default_Iterator
then
160 return Expression
(Aspect_Rep_Item
(Ritem
));
162 return Expression
(Ritem
);
166 Next_Rep_Item
(Ritem
);
176 procedure Move_Aspects
(From
: Node_Id
; To
: Node_Id
) is
177 pragma Assert
(not Has_Aspects
(To
));
179 if Has_Aspects
(From
) then
180 Set_Aspect_Specifications
(To
, Aspect_Specifications
(From
));
181 Aspect_Specifications_Hash_Table
.Remove
(From
);
182 Set_Has_Aspects
(From
, False);
186 -----------------------------------
187 -- Permits_Aspect_Specifications --
188 -----------------------------------
190 Has_Aspect_Specifications_Flag
: constant array (Node_Kind
) of Boolean :=
191 (N_Abstract_Subprogram_Declaration
=> True,
192 N_Component_Declaration
=> True,
193 N_Entry_Declaration
=> True,
194 N_Exception_Declaration
=> True,
195 N_Exception_Renaming_Declaration
=> True,
196 N_Expression_Function
=> True,
197 N_Formal_Abstract_Subprogram_Declaration
=> True,
198 N_Formal_Concrete_Subprogram_Declaration
=> True,
199 N_Formal_Object_Declaration
=> True,
200 N_Formal_Package_Declaration
=> True,
201 N_Formal_Type_Declaration
=> True,
202 N_Full_Type_Declaration
=> True,
203 N_Function_Instantiation
=> True,
204 N_Generic_Package_Declaration
=> True,
205 N_Generic_Renaming_Declaration
=> True,
206 N_Generic_Subprogram_Declaration
=> True,
207 N_Object_Declaration
=> True,
208 N_Object_Renaming_Declaration
=> True,
209 N_Package_Declaration
=> True,
210 N_Package_Instantiation
=> True,
211 N_Package_Specification
=> True,
212 N_Package_Renaming_Declaration
=> True,
213 N_Private_Extension_Declaration
=> True,
214 N_Private_Type_Declaration
=> True,
215 N_Procedure_Instantiation
=> True,
216 N_Protected_Body
=> True,
217 N_Protected_Type_Declaration
=> True,
218 N_Single_Protected_Declaration
=> True,
219 N_Single_Task_Declaration
=> True,
220 N_Subprogram_Body
=> True,
221 N_Subprogram_Declaration
=> True,
222 N_Subprogram_Renaming_Declaration
=> True,
223 N_Subtype_Declaration
=> True,
225 N_Task_Type_Declaration
=> True,
228 function Permits_Aspect_Specifications
(N
: Node_Id
) return Boolean is
230 return Has_Aspect_Specifications_Flag
(Nkind
(N
));
231 end Permits_Aspect_Specifications
;
237 -- Table used for Same_Aspect, maps aspect to canonical aspect
239 Canonical_Aspect
: constant array (Aspect_Id
) of Aspect_Id
:=
240 (No_Aspect
=> No_Aspect
,
241 Aspect_Ada_2005
=> Aspect_Ada_2005
,
242 Aspect_Ada_2012
=> Aspect_Ada_2005
,
243 Aspect_Address
=> Aspect_Address
,
244 Aspect_Alignment
=> Aspect_Alignment
,
245 Aspect_All_Calls_Remote
=> Aspect_All_Calls_Remote
,
246 Aspect_Asynchronous
=> Aspect_Asynchronous
,
247 Aspect_Atomic
=> Aspect_Atomic
,
248 Aspect_Atomic_Components
=> Aspect_Atomic_Components
,
249 Aspect_Attach_Handler
=> Aspect_Attach_Handler
,
250 Aspect_Bit_Order
=> Aspect_Bit_Order
,
251 Aspect_Compiler_Unit
=> Aspect_Compiler_Unit
,
252 Aspect_Component_Size
=> Aspect_Component_Size
,
253 Aspect_Constant_Indexing
=> Aspect_Constant_Indexing
,
254 Aspect_Contract_Case
=> Aspect_Contract_Case
,
255 Aspect_Convention
=> Aspect_Convention
,
256 Aspect_CPU
=> Aspect_CPU
,
257 Aspect_Default_Component_Value
=> Aspect_Default_Component_Value
,
258 Aspect_Default_Iterator
=> Aspect_Default_Iterator
,
259 Aspect_Default_Value
=> Aspect_Default_Value
,
260 Aspect_Dimension
=> Aspect_Dimension
,
261 Aspect_Dimension_System
=> Aspect_Dimension_System
,
262 Aspect_Discard_Names
=> Aspect_Discard_Names
,
263 Aspect_Dispatching_Domain
=> Aspect_Dispatching_Domain
,
264 Aspect_Dynamic_Predicate
=> Aspect_Predicate
,
265 Aspect_Elaborate_Body
=> Aspect_Elaborate_Body
,
266 Aspect_Export
=> Aspect_Export
,
267 Aspect_External_Name
=> Aspect_External_Name
,
268 Aspect_External_Tag
=> Aspect_External_Tag
,
269 Aspect_Favor_Top_Level
=> Aspect_Favor_Top_Level
,
270 Aspect_Implicit_Dereference
=> Aspect_Implicit_Dereference
,
271 Aspect_Import
=> Aspect_Import
,
272 Aspect_Independent
=> Aspect_Independent
,
273 Aspect_Independent_Components
=> Aspect_Independent_Components
,
274 Aspect_Inline
=> Aspect_Inline
,
275 Aspect_Inline_Always
=> Aspect_Inline
,
276 Aspect_Input
=> Aspect_Input
,
277 Aspect_Interrupt_Handler
=> Aspect_Interrupt_Handler
,
278 Aspect_Interrupt_Priority
=> Aspect_Interrupt_Priority
,
279 Aspect_Invariant
=> Aspect_Invariant
,
280 Aspect_Iterator_Element
=> Aspect_Iterator_Element
,
281 Aspect_Link_Name
=> Aspect_Link_Name
,
282 Aspect_Lock_Free
=> Aspect_Lock_Free
,
283 Aspect_Machine_Radix
=> Aspect_Machine_Radix
,
284 Aspect_No_Return
=> Aspect_No_Return
,
285 Aspect_Object_Size
=> Aspect_Object_Size
,
286 Aspect_Output
=> Aspect_Output
,
287 Aspect_Pack
=> Aspect_Pack
,
288 Aspect_Persistent_BSS
=> Aspect_Persistent_BSS
,
289 Aspect_Post
=> Aspect_Post
,
290 Aspect_Postcondition
=> Aspect_Post
,
291 Aspect_Pre
=> Aspect_Pre
,
292 Aspect_Precondition
=> Aspect_Pre
,
293 Aspect_Predicate
=> Aspect_Predicate
,
294 Aspect_Preelaborate
=> Aspect_Preelaborate
,
295 Aspect_Preelaborate_05
=> Aspect_Preelaborate_05
,
296 Aspect_Preelaborable_Initialization
=> Aspect_Preelaborable_Initialization
,
297 Aspect_Priority
=> Aspect_Priority
,
298 Aspect_Pure
=> Aspect_Pure
,
299 Aspect_Pure_05
=> Aspect_Pure_05
,
300 Aspect_Pure_12
=> Aspect_Pure_12
,
301 Aspect_Pure_Function
=> Aspect_Pure_Function
,
302 Aspect_Remote_Access_Type
=> Aspect_Remote_Access_Type
,
303 Aspect_Remote_Call_Interface
=> Aspect_Remote_Call_Interface
,
304 Aspect_Remote_Types
=> Aspect_Remote_Types
,
305 Aspect_Read
=> Aspect_Read
,
306 Aspect_Scalar_Storage_Order
=> Aspect_Scalar_Storage_Order
,
307 Aspect_Shared
=> Aspect_Atomic
,
308 Aspect_Shared_Passive
=> Aspect_Shared_Passive
,
309 Aspect_Simple_Storage_Pool
=> Aspect_Simple_Storage_Pool
,
310 Aspect_Simple_Storage_Pool_Type
=> Aspect_Simple_Storage_Pool_Type
,
311 Aspect_Size
=> Aspect_Size
,
312 Aspect_Small
=> Aspect_Small
,
313 Aspect_Static_Predicate
=> Aspect_Predicate
,
314 Aspect_Storage_Pool
=> Aspect_Storage_Pool
,
315 Aspect_Storage_Size
=> Aspect_Storage_Size
,
316 Aspect_Stream_Size
=> Aspect_Stream_Size
,
317 Aspect_Suppress
=> Aspect_Suppress
,
318 Aspect_Suppress_Debug_Info
=> Aspect_Suppress_Debug_Info
,
319 Aspect_Synchronization
=> Aspect_Synchronization
,
320 Aspect_Test_Case
=> Aspect_Test_Case
,
321 Aspect_Type_Invariant
=> Aspect_Invariant
,
322 Aspect_Unchecked_Union
=> Aspect_Unchecked_Union
,
323 Aspect_Universal_Aliasing
=> Aspect_Universal_Aliasing
,
324 Aspect_Universal_Data
=> Aspect_Universal_Data
,
325 Aspect_Unmodified
=> Aspect_Unmodified
,
326 Aspect_Unreferenced
=> Aspect_Unreferenced
,
327 Aspect_Unreferenced_Objects
=> Aspect_Unreferenced_Objects
,
328 Aspect_Unsuppress
=> Aspect_Unsuppress
,
329 Aspect_Variable_Indexing
=> Aspect_Variable_Indexing
,
330 Aspect_Value_Size
=> Aspect_Value_Size
,
331 Aspect_Volatile
=> Aspect_Volatile
,
332 Aspect_Volatile_Components
=> Aspect_Volatile_Components
,
333 Aspect_Warnings
=> Aspect_Warnings
,
334 Aspect_Write
=> Aspect_Write
);
336 function Same_Aspect
(A1
: Aspect_Id
; A2
: Aspect_Id
) return Boolean is
338 return Canonical_Aspect
(A1
) = Canonical_Aspect
(A2
);
341 -------------------------------
342 -- Set_Aspect_Specifications --
343 -------------------------------
345 procedure Set_Aspect_Specifications
(N
: Node_Id
; L
: List_Id
) is
347 pragma Assert
(Permits_Aspect_Specifications
(N
));
348 pragma Assert
(not Has_Aspects
(N
));
349 pragma Assert
(L
/= No_List
);
353 Aspect_Specifications_Hash_Table
.Set
(N
, L
);
354 end Set_Aspect_Specifications
;
356 ----------------------------------------
357 -- Set_Aspect_Specifications_No_Check --
358 ----------------------------------------
360 procedure Set_Aspect_Specifications_No_Check
(N
: Node_Id
; L
: List_Id
) is
362 pragma Assert
(Permits_Aspect_Specifications
(N
));
363 pragma Assert
(L
/= No_List
);
367 Aspect_Specifications_Hash_Table
.Set
(N
, L
);
368 end Set_Aspect_Specifications_No_Check
;
374 procedure Tree_Read
is
379 Tree_Read_Int
(Int
(Node
));
380 Tree_Read_Int
(Int
(List
));
381 exit when List
= No_List
;
382 Set_Aspect_Specifications_No_Check
(Node
, List
);
390 procedure Tree_Write
is
391 Node
: Node_Id
:= Empty
;
394 Aspect_Specifications_Hash_Table
.Get_First
(Node
, List
);
396 Tree_Write_Int
(Int
(Node
));
397 Tree_Write_Int
(Int
(List
));
398 exit when List
= No_List
;
399 Aspect_Specifications_Hash_Table
.Get_Next
(Node
, List
);
403 -- Package initialization sets up Aspect Id hash table
406 for J
in Aspect_Id
loop
407 Aspect_Id_Hash_Table
.Set
(Aspect_Names
(J
), J
);