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_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);