1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2010-2011, 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 Nlists; use Nlists;
34 with Sinfo; use Sinfo;
35 with Tree_IO; use Tree_IO;
37 with GNAT.HTable; use GNAT.HTable;
39 package body Aspects is
41 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id);
42 -- Same as Set_Aspect_Specifications, but does not contain the assertion
43 -- that checks that N does not already have aspect specifications. This
44 -- subprogram is supposed to be used as a part of Tree_Read. When reading
45 -- tree, first read nodes with their basic properties (as Atree.Tree_Read),
46 -- this includes reading the Has_Aspects flag for each node, then we reed
47 -- all the list tables and only after that we call Tree_Read for Aspects.
48 -- That is, when reading the tree, the list of aspects is attached to the
49 -- node that already has Has_Aspects flag set ON.
51 ------------------------------------------
52 -- Hash Table for Aspect Specifications --
53 ------------------------------------------
55 type AS_Hash_Range is range 0 .. 510;
56 -- Size of hash table headers
58 function AS_Hash (F : Node_Id) return AS_Hash_Range;
59 -- Hash function for hash table
61 function AS_Hash (F : Node_Id) return AS_Hash_Range is
63 return AS_Hash_Range (F mod 511);
66 package Aspect_Specifications_Hash_Table is new
67 GNAT.HTable.Simple_HTable
68 (Header_Num => AS_Hash_Range,
70 No_Element => No_List,
75 -------------------------------------
76 -- Hash Table for Aspect Id Values --
77 -------------------------------------
79 type AI_Hash_Range is range 0 .. 112;
80 -- Size of hash table headers
82 function AI_Hash (F : Name_Id) return AI_Hash_Range;
83 -- Hash function for hash table
85 function AI_Hash (F : Name_Id) return AI_Hash_Range is
87 return AI_Hash_Range (F mod 113);
90 package Aspect_Id_Hash_Table is new
91 GNAT.HTable.Simple_HTable
92 (Header_Num => AI_Hash_Range,
94 No_Element => No_Aspect,
99 ---------------------------
100 -- Aspect_Specifications --
101 ---------------------------
103 function Aspect_Specifications (N : Node_Id) return List_Id is
105 if Has_Aspects (N) then
106 return Aspect_Specifications_Hash_Table.Get (N);
110 end Aspect_Specifications;
116 function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
118 return Aspect_Id_Hash_Table.Get (Name);
125 procedure Move_Aspects (From : Node_Id; To : Node_Id) is
126 pragma Assert (not Has_Aspects (To));
128 if Has_Aspects (From) then
129 Set_Aspect_Specifications (To, Aspect_Specifications (From));
130 Aspect_Specifications_Hash_Table.Remove (From);
131 Set_Has_Aspects (From, False);
135 -----------------------------------
136 -- Permits_Aspect_Specifications --
137 -----------------------------------
139 Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
140 (N_Abstract_Subprogram_Declaration => True,
141 N_Component_Declaration => True,
142 N_Entry_Declaration => True,
143 N_Exception_Declaration => True,
144 N_Formal_Abstract_Subprogram_Declaration => True,
145 N_Formal_Concrete_Subprogram_Declaration => True,
146 N_Formal_Object_Declaration => True,
147 N_Formal_Package_Declaration => True,
148 N_Formal_Type_Declaration => True,
149 N_Full_Type_Declaration => True,
150 N_Function_Instantiation => True,
151 N_Generic_Package_Declaration => True,
152 N_Generic_Subprogram_Declaration => True,
153 N_Object_Declaration => True,
154 N_Package_Declaration => True,
155 N_Package_Instantiation => True,
156 N_Package_Specification => True,
157 N_Private_Extension_Declaration => True,
158 N_Private_Type_Declaration => True,
159 N_Procedure_Instantiation => True,
160 N_Protected_Body => True,
161 N_Protected_Type_Declaration => True,
162 N_Single_Protected_Declaration => True,
163 N_Single_Task_Declaration => True,
164 N_Subprogram_Body => True,
165 N_Subprogram_Declaration => True,
166 N_Subtype_Declaration => True,
168 N_Task_Type_Declaration => True,
171 function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
173 return Has_Aspect_Specifications_Flag (Nkind (N));
174 end Permits_Aspect_Specifications;
180 -- Table used for Same_Aspect, maps aspect to canonical aspect
182 Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
183 (No_Aspect => No_Aspect,
184 Aspect_Ada_2005 => Aspect_Ada_2005,
185 Aspect_Ada_2012 => Aspect_Ada_2005,
186 Aspect_Address => Aspect_Address,
187 Aspect_Alignment => Aspect_Alignment,
188 Aspect_Asynchronous => Aspect_Asynchronous,
189 Aspect_Atomic => Aspect_Atomic,
190 Aspect_Atomic_Components => Aspect_Atomic_Components,
191 Aspect_Attach_Handler => Aspect_Attach_Handler,
192 Aspect_Bit_Order => Aspect_Bit_Order,
193 Aspect_Component_Size => Aspect_Component_Size,
194 Aspect_Constant_Indexing => Aspect_Constant_Indexing,
195 Aspect_Default_Component_Value => Aspect_Default_Component_Value,
196 Aspect_Default_Iterator => Aspect_Default_Iterator,
197 Aspect_Default_Value => Aspect_Default_Value,
198 Aspect_Discard_Names => Aspect_Discard_Names,
199 Aspect_Dynamic_Predicate => Aspect_Predicate,
200 Aspect_External_Tag => Aspect_External_Tag,
201 Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
202 Aspect_Implicit_Dereference => Aspect_Implicit_Dereference,
203 Aspect_Independent => Aspect_Independent,
204 Aspect_Independent_Components => Aspect_Independent_Components,
205 Aspect_Inline => Aspect_Inline,
206 Aspect_Inline_Always => Aspect_Inline,
207 Aspect_Interrupt_Handler => Aspect_Interrupt_Handler,
208 Aspect_Interrupt_Priority => Aspect_Interrupt_Priority,
209 Aspect_Iterator_Element => Aspect_Iterator_Element,
210 Aspect_All_Calls_Remote => Aspect_All_Calls_Remote,
211 Aspect_Compiler_Unit => Aspect_Compiler_Unit,
212 Aspect_Elaborate_Body => Aspect_Elaborate_Body,
213 Aspect_Preelaborate => Aspect_Preelaborate,
214 Aspect_Preelaborate_05 => Aspect_Preelaborate_05,
215 Aspect_Pure => Aspect_Pure,
216 Aspect_Pure_05 => Aspect_Pure_05,
217 Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
218 Aspect_Remote_Types => Aspect_Remote_Types,
219 Aspect_Shared_Passive => Aspect_Shared_Passive,
220 Aspect_Universal_Data => Aspect_Universal_Data,
221 Aspect_Input => Aspect_Input,
222 Aspect_Invariant => Aspect_Invariant,
223 Aspect_Machine_Radix => Aspect_Machine_Radix,
224 Aspect_No_Return => Aspect_No_Return,
225 Aspect_Object_Size => Aspect_Object_Size,
226 Aspect_Output => Aspect_Output,
227 Aspect_Pack => Aspect_Pack,
228 Aspect_Persistent_BSS => Aspect_Persistent_BSS,
229 Aspect_Post => Aspect_Post,
230 Aspect_Postcondition => Aspect_Post,
231 Aspect_Pre => Aspect_Pre,
232 Aspect_Precondition => Aspect_Pre,
233 Aspect_Predicate => Aspect_Predicate,
234 Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
235 Aspect_Priority => Aspect_Priority,
236 Aspect_Pure_Function => Aspect_Pure_Function,
237 Aspect_Read => Aspect_Read,
238 Aspect_Shared => Aspect_Atomic,
239 Aspect_Size => Aspect_Size,
240 Aspect_Small => Aspect_Small,
241 Aspect_Static_Predicate => Aspect_Predicate,
242 Aspect_Storage_Pool => Aspect_Storage_Pool,
243 Aspect_Storage_Size => Aspect_Storage_Size,
244 Aspect_Stream_Size => Aspect_Stream_Size,
245 Aspect_Suppress => Aspect_Suppress,
246 Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info,
247 Aspect_Test_Case => Aspect_Test_Case,
248 Aspect_Type_Invariant => Aspect_Invariant,
249 Aspect_Unchecked_Union => Aspect_Unchecked_Union,
250 Aspect_Universal_Aliasing => Aspect_Universal_Aliasing,
251 Aspect_Unmodified => Aspect_Unmodified,
252 Aspect_Unreferenced => Aspect_Unreferenced,
253 Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects,
254 Aspect_Unsuppress => Aspect_Unsuppress,
255 Aspect_Variable_Indexing => Aspect_Variable_Indexing,
256 Aspect_Value_Size => Aspect_Value_Size,
257 Aspect_Volatile => Aspect_Volatile,
258 Aspect_Volatile_Components => Aspect_Volatile_Components,
259 Aspect_Warnings => Aspect_Warnings,
260 Aspect_Write => Aspect_Write);
262 function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
264 return Canonical_Aspect (A1) = Canonical_Aspect (A2);
267 -------------------------------
268 -- Set_Aspect_Specifications --
269 -------------------------------
271 procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
273 pragma Assert (Permits_Aspect_Specifications (N));
274 pragma Assert (not Has_Aspects (N));
275 pragma Assert (L /= No_List);
279 Aspect_Specifications_Hash_Table.Set (N, L);
280 end Set_Aspect_Specifications;
282 ----------------------------------------
283 -- Set_Aspect_Specifications_No_Check --
284 ----------------------------------------
286 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
288 pragma Assert (Permits_Aspect_Specifications (N));
289 pragma Assert (L /= No_List);
293 Aspect_Specifications_Hash_Table.Set (N, L);
294 end Set_Aspect_Specifications_No_Check;
300 procedure Tree_Read is
305 Tree_Read_Int (Int (Node));
306 Tree_Read_Int (Int (List));
307 exit when List = No_List;
308 Set_Aspect_Specifications_No_Check (Node, List);
316 procedure Tree_Write is
317 Node : Node_Id := Empty;
320 Aspect_Specifications_Hash_Table.Get_First (Node, List);
322 Tree_Write_Int (Int (Node));
323 Tree_Write_Int (Int (List));
324 exit when List = No_List;
325 Aspect_Specifications_Hash_Table.Get_Next (Node, List);
329 -- Package initialization sets up Aspect Id hash table
332 for J in Aspect_Id loop
333 Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);