|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A S P E C T S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 2010-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
21 -- --
|
|
|
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/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
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;
|
|
|
37
|
|
|
38 with GNAT.HTable;
|
|
|
39
|
|
|
40 package body Aspects is
|
|
|
41
|
|
|
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.
|
|
|
45
|
|
|
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,
|
|
|
58 Aspect_Volatile_Full_Access => True,
|
|
|
59 others => False);
|
|
|
60
|
|
|
61 -- The following array indicates type aspects that are inherited and apply
|
|
|
62 -- to the class-wide type as well.
|
|
|
63
|
|
|
64 Inherited_Aspect : constant array (Aspect_Id) of Boolean :=
|
|
|
65 (Aspect_Constant_Indexing => True,
|
|
|
66 Aspect_Default_Iterator => True,
|
|
|
67 Aspect_Implicit_Dereference => True,
|
|
|
68 Aspect_Iterator_Element => True,
|
|
|
69 Aspect_Remote_Types => True,
|
|
|
70 Aspect_Variable_Indexing => True,
|
|
|
71 others => False);
|
|
|
72
|
|
|
73 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id);
|
|
|
74 -- Same as Set_Aspect_Specifications, but does not contain the assertion
|
|
|
75 -- that checks that N does not already have aspect specifications. This
|
|
|
76 -- subprogram is supposed to be used as a part of Tree_Read. When reading
|
|
|
77 -- tree, first read nodes with their basic properties (as Atree.Tree_Read),
|
|
|
78 -- this includes reading the Has_Aspects flag for each node, then we reed
|
|
|
79 -- all the list tables and only after that we call Tree_Read for Aspects.
|
|
|
80 -- That is, when reading the tree, the list of aspects is attached to the
|
|
|
81 -- node that already has Has_Aspects flag set ON.
|
|
|
82
|
|
|
83 ------------------------------------------
|
|
|
84 -- Hash Table for Aspect Specifications --
|
|
|
85 ------------------------------------------
|
|
|
86
|
|
|
87 type AS_Hash_Range is range 0 .. 510;
|
|
|
88 -- Size of hash table headers
|
|
|
89
|
|
|
90 function AS_Hash (F : Node_Id) return AS_Hash_Range;
|
|
|
91 -- Hash function for hash table
|
|
|
92
|
|
|
93 function AS_Hash (F : Node_Id) return AS_Hash_Range is
|
|
|
94 begin
|
|
|
95 return AS_Hash_Range (F mod 511);
|
|
|
96 end AS_Hash;
|
|
|
97
|
|
|
98 package Aspect_Specifications_Hash_Table is new
|
|
|
99 GNAT.HTable.Simple_HTable
|
|
|
100 (Header_Num => AS_Hash_Range,
|
|
|
101 Element => List_Id,
|
|
|
102 No_Element => No_List,
|
|
|
103 Key => Node_Id,
|
|
|
104 Hash => AS_Hash,
|
|
|
105 Equal => "=");
|
|
|
106
|
|
|
107 -------------------------------------
|
|
|
108 -- Hash Table for Aspect Id Values --
|
|
|
109 -------------------------------------
|
|
|
110
|
|
|
111 type AI_Hash_Range is range 0 .. 112;
|
|
|
112 -- Size of hash table headers
|
|
|
113
|
|
|
114 function AI_Hash (F : Name_Id) return AI_Hash_Range;
|
|
|
115 -- Hash function for hash table
|
|
|
116
|
|
|
117 function AI_Hash (F : Name_Id) return AI_Hash_Range is
|
|
|
118 begin
|
|
|
119 return AI_Hash_Range (F mod 113);
|
|
|
120 end AI_Hash;
|
|
|
121
|
|
|
122 package Aspect_Id_Hash_Table is new
|
|
|
123 GNAT.HTable.Simple_HTable
|
|
|
124 (Header_Num => AI_Hash_Range,
|
|
|
125 Element => Aspect_Id,
|
|
|
126 No_Element => No_Aspect,
|
|
|
127 Key => Name_Id,
|
|
|
128 Hash => AI_Hash,
|
|
|
129 Equal => "=");
|
|
|
130
|
|
|
131 ---------------------------
|
|
|
132 -- Aspect_Specifications --
|
|
|
133 ---------------------------
|
|
|
134
|
|
|
135 function Aspect_Specifications (N : Node_Id) return List_Id is
|
|
|
136 begin
|
|
|
137 if Has_Aspects (N) then
|
|
|
138 return Aspect_Specifications_Hash_Table.Get (N);
|
|
|
139 else
|
|
|
140 return No_List;
|
|
|
141 end if;
|
|
|
142 end Aspect_Specifications;
|
|
|
143
|
|
|
144 --------------------------------
|
|
|
145 -- Aspects_On_Body_Or_Stub_OK --
|
|
|
146 --------------------------------
|
|
|
147
|
|
|
148 function Aspects_On_Body_Or_Stub_OK (N : Node_Id) return Boolean is
|
|
|
149 Aspect : Node_Id;
|
|
|
150 Aspects : List_Id;
|
|
|
151
|
|
|
152 begin
|
|
|
153 -- The routine should be invoked on a body [stub] with aspects
|
|
|
154
|
|
|
155 pragma Assert (Has_Aspects (N));
|
|
|
156 pragma Assert (Nkind (N) in N_Body_Stub
|
|
|
157 or else Nkind_In (N, N_Entry_Body,
|
|
|
158 N_Package_Body,
|
|
|
159 N_Protected_Body,
|
|
|
160 N_Subprogram_Body,
|
|
|
161 N_Task_Body));
|
|
|
162
|
|
|
163 -- Look through all aspects and see whether they can be applied to a
|
|
|
164 -- body [stub].
|
|
|
165
|
|
|
166 Aspects := Aspect_Specifications (N);
|
|
|
167 Aspect := First (Aspects);
|
|
|
168 while Present (Aspect) loop
|
|
|
169 if not Aspect_On_Body_Or_Stub_OK (Get_Aspect_Id (Aspect)) then
|
|
|
170 return False;
|
|
|
171 end if;
|
|
|
172
|
|
|
173 Next (Aspect);
|
|
|
174 end loop;
|
|
|
175
|
|
|
176 return True;
|
|
|
177 end Aspects_On_Body_Or_Stub_OK;
|
|
|
178
|
|
|
179 ----------------------
|
|
|
180 -- Exchange_Aspects --
|
|
|
181 ----------------------
|
|
|
182
|
|
|
183 procedure Exchange_Aspects (N1 : Node_Id; N2 : Node_Id) is
|
|
|
184 begin
|
|
|
185 pragma Assert
|
|
|
186 (Permits_Aspect_Specifications (N1)
|
|
|
187 and then Permits_Aspect_Specifications (N2));
|
|
|
188
|
|
|
189 -- Perform the exchange only when both nodes have lists to be swapped
|
|
|
190
|
|
|
191 if Has_Aspects (N1) and then Has_Aspects (N2) then
|
|
|
192 declare
|
|
|
193 L1 : constant List_Id := Aspect_Specifications (N1);
|
|
|
194 L2 : constant List_Id := Aspect_Specifications (N2);
|
|
|
195 begin
|
|
|
196 Set_Parent (L1, N2);
|
|
|
197 Set_Parent (L2, N1);
|
|
|
198 Aspect_Specifications_Hash_Table.Set (N1, L2);
|
|
|
199 Aspect_Specifications_Hash_Table.Set (N2, L1);
|
|
|
200 end;
|
|
|
201 end if;
|
|
|
202 end Exchange_Aspects;
|
|
|
203
|
|
|
204 -----------------
|
|
|
205 -- Find_Aspect --
|
|
|
206 -----------------
|
|
|
207
|
|
|
208 function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id is
|
|
|
209 Decl : Node_Id;
|
|
|
210 Item : Node_Id;
|
|
|
211 Owner : Entity_Id;
|
|
|
212 Spec : Node_Id;
|
|
|
213
|
|
|
214 begin
|
|
|
215 Owner := Id;
|
|
|
216
|
|
|
217 -- Handle various cases of base or inherited aspects for types
|
|
|
218
|
|
|
219 if Is_Type (Id) then
|
|
|
220 if Base_Aspect (A) then
|
|
|
221 Owner := Base_Type (Owner);
|
|
|
222 end if;
|
|
|
223
|
|
|
224 if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then
|
|
|
225 Owner := Root_Type (Owner);
|
|
|
226 end if;
|
|
|
227
|
|
145
|
228 if Is_Private_Type (Owner)
|
|
|
229 and then Present (Full_View (Owner))
|
|
|
230 and then not Operational_Aspect (A)
|
|
|
231 then
|
|
111
|
232 Owner := Full_View (Owner);
|
|
|
233 end if;
|
|
|
234 end if;
|
|
|
235
|
|
|
236 -- Search the representation items for the desired aspect
|
|
|
237
|
|
|
238 Item := First_Rep_Item (Owner);
|
|
|
239 while Present (Item) loop
|
|
|
240 if Nkind (Item) = N_Aspect_Specification
|
|
|
241 and then Get_Aspect_Id (Item) = A
|
|
|
242 then
|
|
|
243 return Item;
|
|
|
244 end if;
|
|
|
245
|
|
|
246 Next_Rep_Item (Item);
|
|
|
247 end loop;
|
|
|
248
|
|
|
249 -- Note that not all aspects are added to the chain of representation
|
|
|
250 -- items. In such cases, search the list of aspect specifications. First
|
|
|
251 -- find the declaration node where the aspects reside. This is usually
|
|
|
252 -- the parent or the parent of the parent.
|
|
|
253
|
|
|
254 Decl := Parent (Owner);
|
|
|
255 if not Permits_Aspect_Specifications (Decl) then
|
|
|
256 Decl := Parent (Decl);
|
|
|
257 end if;
|
|
|
258
|
|
|
259 -- Search the list of aspect specifications for the desired aspect
|
|
|
260
|
|
|
261 if Permits_Aspect_Specifications (Decl) then
|
|
|
262 Spec := First (Aspect_Specifications (Decl));
|
|
|
263 while Present (Spec) loop
|
|
|
264 if Get_Aspect_Id (Spec) = A then
|
|
|
265 return Spec;
|
|
|
266 end if;
|
|
|
267
|
|
|
268 Next (Spec);
|
|
|
269 end loop;
|
|
|
270 end if;
|
|
|
271
|
|
|
272 -- The entity does not carry any aspects or the desired aspect was not
|
|
|
273 -- found.
|
|
|
274
|
|
|
275 return Empty;
|
|
|
276 end Find_Aspect;
|
|
|
277
|
|
|
278 --------------------------
|
|
|
279 -- Find_Value_Of_Aspect --
|
|
|
280 --------------------------
|
|
|
281
|
|
|
282 function Find_Value_Of_Aspect
|
|
|
283 (Id : Entity_Id;
|
|
|
284 A : Aspect_Id) return Node_Id
|
|
|
285 is
|
|
|
286 Spec : constant Node_Id := Find_Aspect (Id, A);
|
|
|
287
|
|
|
288 begin
|
|
|
289 if Present (Spec) then
|
|
|
290 if A = Aspect_Default_Iterator then
|
|
|
291 return Expression (Aspect_Rep_Item (Spec));
|
|
|
292 else
|
|
|
293 return Expression (Spec);
|
|
|
294 end if;
|
|
|
295 end if;
|
|
|
296
|
|
|
297 return Empty;
|
|
|
298 end Find_Value_Of_Aspect;
|
|
|
299
|
|
|
300 -------------------
|
|
|
301 -- Get_Aspect_Id --
|
|
|
302 -------------------
|
|
|
303
|
|
|
304 function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is
|
|
|
305 begin
|
|
|
306 return Aspect_Id_Hash_Table.Get (Name);
|
|
|
307 end Get_Aspect_Id;
|
|
|
308
|
|
|
309 function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is
|
|
|
310 begin
|
|
|
311 pragma Assert (Nkind (Aspect) = N_Aspect_Specification);
|
|
|
312 return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect)));
|
|
|
313 end Get_Aspect_Id;
|
|
|
314
|
|
|
315 ----------------
|
|
|
316 -- Has_Aspect --
|
|
|
317 ----------------
|
|
|
318
|
|
|
319 function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is
|
|
|
320 begin
|
|
|
321 return Present (Find_Aspect (Id, A));
|
|
|
322 end Has_Aspect;
|
|
|
323
|
|
|
324 ------------------
|
|
|
325 -- Move_Aspects --
|
|
|
326 ------------------
|
|
|
327
|
|
|
328 procedure Move_Aspects (From : Node_Id; To : Node_Id) is
|
|
|
329 pragma Assert (not Has_Aspects (To));
|
|
|
330 begin
|
|
|
331 if Has_Aspects (From) then
|
|
|
332 Set_Aspect_Specifications (To, Aspect_Specifications (From));
|
|
|
333 Aspect_Specifications_Hash_Table.Remove (From);
|
|
|
334 Set_Has_Aspects (From, False);
|
|
|
335 end if;
|
|
|
336 end Move_Aspects;
|
|
|
337
|
|
|
338 ---------------------------
|
|
|
339 -- Move_Or_Merge_Aspects --
|
|
|
340 ---------------------------
|
|
|
341
|
|
|
342 procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is
|
|
|
343 procedure Relocate_Aspect (Asp : Node_Id);
|
|
|
344 -- Move aspect specification Asp to the aspect specifications of node To
|
|
|
345
|
|
|
346 ---------------------
|
|
|
347 -- Relocate_Aspect --
|
|
|
348 ---------------------
|
|
|
349
|
|
|
350 procedure Relocate_Aspect (Asp : Node_Id) is
|
|
|
351 Asps : List_Id;
|
|
|
352
|
|
|
353 begin
|
|
|
354 if Has_Aspects (To) then
|
|
|
355 Asps := Aspect_Specifications (To);
|
|
|
356
|
|
|
357 -- Create a new aspect specification list for node To
|
|
|
358
|
|
|
359 else
|
|
|
360 Asps := New_List;
|
|
|
361 Set_Aspect_Specifications (To, Asps);
|
|
|
362 Set_Has_Aspects (To);
|
|
|
363 end if;
|
|
|
364
|
|
|
365 -- Remove the aspect from its original owner and relocate it to node
|
|
|
366 -- To.
|
|
|
367
|
|
|
368 Remove (Asp);
|
|
|
369 Append (Asp, Asps);
|
|
|
370 end Relocate_Aspect;
|
|
|
371
|
|
|
372 -- Local variables
|
|
|
373
|
|
|
374 Asp : Node_Id;
|
|
|
375 Asp_Id : Aspect_Id;
|
|
|
376 Next_Asp : Node_Id;
|
|
|
377
|
|
|
378 -- Start of processing for Move_Or_Merge_Aspects
|
|
|
379
|
|
|
380 begin
|
|
|
381 if Has_Aspects (From) then
|
|
|
382 Asp := First (Aspect_Specifications (From));
|
|
|
383 while Present (Asp) loop
|
|
|
384
|
|
|
385 -- Store the next aspect now as a potential relocation will alter
|
|
|
386 -- the contents of the list.
|
|
|
387
|
|
|
388 Next_Asp := Next (Asp);
|
|
|
389
|
|
|
390 -- When moving or merging aspects from a subprogram body stub that
|
|
|
391 -- also acts as a spec, relocate only those aspects that may apply
|
|
|
392 -- to a body [stub]. Note that a precondition must also be moved
|
|
|
393 -- to the proper body as the pre/post machinery expects it to be
|
|
|
394 -- there.
|
|
|
395
|
|
|
396 if Nkind (From) = N_Subprogram_Body_Stub
|
|
|
397 and then No (Corresponding_Spec_Of_Stub (From))
|
|
|
398 then
|
|
|
399 Asp_Id := Get_Aspect_Id (Asp);
|
|
|
400
|
|
|
401 if Aspect_On_Body_Or_Stub_OK (Asp_Id)
|
|
|
402 or else Asp_Id = Aspect_Pre
|
|
|
403 or else Asp_Id = Aspect_Precondition
|
|
|
404 then
|
|
|
405 Relocate_Aspect (Asp);
|
|
|
406 end if;
|
|
|
407
|
|
|
408 -- When moving or merging aspects from a single concurrent type
|
|
|
409 -- declaration, relocate only those aspects that may apply to the
|
|
|
410 -- anonymous object created for the type.
|
|
|
411
|
|
|
412 -- Note: It is better to use Is_Single_Concurrent_Type_Declaration
|
|
|
413 -- here, but Aspects and Sem_Util have incompatible licenses.
|
|
|
414
|
|
|
415 elsif Nkind_In
|
|
|
416 (Original_Node (From), N_Single_Protected_Declaration,
|
|
|
417 N_Single_Task_Declaration)
|
|
|
418 then
|
|
|
419 Asp_Id := Get_Aspect_Id (Asp);
|
|
|
420
|
|
|
421 if Aspect_On_Anonymous_Object_OK (Asp_Id) then
|
|
|
422 Relocate_Aspect (Asp);
|
|
|
423 end if;
|
|
|
424
|
|
|
425 -- Default case - relocate the aspect to its new owner
|
|
|
426
|
|
|
427 else
|
|
|
428 Relocate_Aspect (Asp);
|
|
|
429 end if;
|
|
|
430
|
|
|
431 Asp := Next_Asp;
|
|
|
432 end loop;
|
|
|
433
|
|
|
434 -- The relocations may have left node From's aspect specifications
|
|
|
435 -- list empty. If this is the case, simply remove the aspects.
|
|
|
436
|
|
|
437 if Is_Empty_List (Aspect_Specifications (From)) then
|
|
|
438 Remove_Aspects (From);
|
|
|
439 end if;
|
|
|
440 end if;
|
|
|
441 end Move_Or_Merge_Aspects;
|
|
|
442
|
|
|
443 -----------------------------------
|
|
|
444 -- Permits_Aspect_Specifications --
|
|
|
445 -----------------------------------
|
|
|
446
|
|
|
447 Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
|
|
|
448 (N_Abstract_Subprogram_Declaration => True,
|
|
|
449 N_Component_Declaration => True,
|
|
|
450 N_Entry_Body => True,
|
|
|
451 N_Entry_Declaration => True,
|
|
|
452 N_Exception_Declaration => True,
|
|
|
453 N_Exception_Renaming_Declaration => True,
|
|
|
454 N_Expression_Function => True,
|
|
|
455 N_Formal_Abstract_Subprogram_Declaration => True,
|
|
|
456 N_Formal_Concrete_Subprogram_Declaration => True,
|
|
|
457 N_Formal_Object_Declaration => True,
|
|
|
458 N_Formal_Package_Declaration => True,
|
|
|
459 N_Formal_Type_Declaration => True,
|
|
|
460 N_Full_Type_Declaration => True,
|
|
|
461 N_Function_Instantiation => True,
|
|
|
462 N_Generic_Package_Declaration => True,
|
|
|
463 N_Generic_Renaming_Declaration => True,
|
|
|
464 N_Generic_Subprogram_Declaration => True,
|
|
|
465 N_Object_Declaration => True,
|
|
|
466 N_Object_Renaming_Declaration => True,
|
|
|
467 N_Package_Body => True,
|
|
|
468 N_Package_Body_Stub => True,
|
|
|
469 N_Package_Declaration => True,
|
|
|
470 N_Package_Instantiation => True,
|
|
|
471 N_Package_Specification => True,
|
|
|
472 N_Package_Renaming_Declaration => True,
|
|
|
473 N_Private_Extension_Declaration => True,
|
|
|
474 N_Private_Type_Declaration => True,
|
|
|
475 N_Procedure_Instantiation => True,
|
|
|
476 N_Protected_Body => True,
|
|
|
477 N_Protected_Body_Stub => True,
|
|
|
478 N_Protected_Type_Declaration => True,
|
|
|
479 N_Single_Protected_Declaration => True,
|
|
|
480 N_Single_Task_Declaration => True,
|
|
|
481 N_Subprogram_Body => True,
|
|
|
482 N_Subprogram_Body_Stub => True,
|
|
|
483 N_Subprogram_Declaration => True,
|
|
|
484 N_Subprogram_Renaming_Declaration => True,
|
|
|
485 N_Subtype_Declaration => True,
|
|
|
486 N_Task_Body => True,
|
|
|
487 N_Task_Body_Stub => True,
|
|
|
488 N_Task_Type_Declaration => True,
|
|
|
489 others => False);
|
|
|
490
|
|
|
491 function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
|
|
|
492 begin
|
|
|
493 return Has_Aspect_Specifications_Flag (Nkind (N));
|
|
|
494 end Permits_Aspect_Specifications;
|
|
|
495
|
|
|
496 --------------------
|
|
|
497 -- Remove_Aspects --
|
|
|
498 --------------------
|
|
|
499
|
|
|
500 procedure Remove_Aspects (N : Node_Id) is
|
|
|
501 begin
|
|
|
502 if Has_Aspects (N) then
|
|
|
503 Aspect_Specifications_Hash_Table.Remove (N);
|
|
|
504 Set_Has_Aspects (N, False);
|
|
|
505 end if;
|
|
|
506 end Remove_Aspects;
|
|
|
507
|
|
|
508 -----------------
|
|
|
509 -- Same_Aspect --
|
|
|
510 -----------------
|
|
|
511
|
|
|
512 -- Table used for Same_Aspect, maps aspect to canonical aspect
|
|
|
513
|
|
|
514 Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
|
|
|
515 (No_Aspect => No_Aspect,
|
|
|
516 Aspect_Abstract_State => Aspect_Abstract_State,
|
|
|
517 Aspect_Address => Aspect_Address,
|
|
|
518 Aspect_Alignment => Aspect_Alignment,
|
|
|
519 Aspect_All_Calls_Remote => Aspect_All_Calls_Remote,
|
|
|
520 Aspect_Annotate => Aspect_Annotate,
|
|
|
521 Aspect_Async_Readers => Aspect_Async_Readers,
|
|
|
522 Aspect_Async_Writers => Aspect_Async_Writers,
|
|
|
523 Aspect_Asynchronous => Aspect_Asynchronous,
|
|
|
524 Aspect_Atomic => Aspect_Atomic,
|
|
|
525 Aspect_Atomic_Components => Aspect_Atomic_Components,
|
|
|
526 Aspect_Attach_Handler => Aspect_Attach_Handler,
|
|
|
527 Aspect_Bit_Order => Aspect_Bit_Order,
|
|
|
528 Aspect_Component_Size => Aspect_Component_Size,
|
|
|
529 Aspect_Constant_After_Elaboration => Aspect_Constant_After_Elaboration,
|
|
|
530 Aspect_Constant_Indexing => Aspect_Constant_Indexing,
|
|
|
531 Aspect_Contract_Cases => Aspect_Contract_Cases,
|
|
|
532 Aspect_Convention => Aspect_Convention,
|
|
|
533 Aspect_CPU => Aspect_CPU,
|
|
|
534 Aspect_Default_Component_Value => Aspect_Default_Component_Value,
|
|
|
535 Aspect_Default_Initial_Condition => Aspect_Default_Initial_Condition,
|
|
|
536 Aspect_Default_Iterator => Aspect_Default_Iterator,
|
|
|
537 Aspect_Default_Storage_Pool => Aspect_Default_Storage_Pool,
|
|
|
538 Aspect_Default_Value => Aspect_Default_Value,
|
|
|
539 Aspect_Depends => Aspect_Depends,
|
|
|
540 Aspect_Dimension => Aspect_Dimension,
|
|
|
541 Aspect_Dimension_System => Aspect_Dimension_System,
|
|
|
542 Aspect_Disable_Controlled => Aspect_Disable_Controlled,
|
|
|
543 Aspect_Discard_Names => Aspect_Discard_Names,
|
|
|
544 Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
|
|
|
545 Aspect_Dynamic_Predicate => Aspect_Predicate,
|
|
|
546 Aspect_Effective_Reads => Aspect_Effective_Reads,
|
|
|
547 Aspect_Effective_Writes => Aspect_Effective_Writes,
|
|
|
548 Aspect_Elaborate_Body => Aspect_Elaborate_Body,
|
|
|
549 Aspect_Export => Aspect_Export,
|
|
|
550 Aspect_Extensions_Visible => Aspect_Extensions_Visible,
|
|
|
551 Aspect_External_Name => Aspect_External_Name,
|
|
|
552 Aspect_External_Tag => Aspect_External_Tag,
|
|
|
553 Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
|
|
|
554 Aspect_Ghost => Aspect_Ghost,
|
|
|
555 Aspect_Global => Aspect_Global,
|
|
|
556 Aspect_Implicit_Dereference => Aspect_Implicit_Dereference,
|
|
|
557 Aspect_Import => Aspect_Import,
|
|
|
558 Aspect_Independent => Aspect_Independent,
|
|
|
559 Aspect_Independent_Components => Aspect_Independent_Components,
|
|
|
560 Aspect_Inline => Aspect_Inline,
|
|
|
561 Aspect_Inline_Always => Aspect_Inline,
|
|
|
562 Aspect_Initial_Condition => Aspect_Initial_Condition,
|
|
|
563 Aspect_Initializes => Aspect_Initializes,
|
|
|
564 Aspect_Input => Aspect_Input,
|
|
|
565 Aspect_Interrupt_Handler => Aspect_Interrupt_Handler,
|
|
|
566 Aspect_Interrupt_Priority => Aspect_Priority,
|
|
|
567 Aspect_Invariant => Aspect_Invariant,
|
|
|
568 Aspect_Iterable => Aspect_Iterable,
|
|
|
569 Aspect_Iterator_Element => Aspect_Iterator_Element,
|
|
|
570 Aspect_Link_Name => Aspect_Link_Name,
|
|
|
571 Aspect_Linker_Section => Aspect_Linker_Section,
|
|
|
572 Aspect_Lock_Free => Aspect_Lock_Free,
|
|
|
573 Aspect_Machine_Radix => Aspect_Machine_Radix,
|
|
131
|
574 Aspect_Max_Entry_Queue_Depth => Aspect_Max_Entry_Queue_Depth,
|
|
145
|
575 Aspect_Max_Entry_Queue_Length => Aspect_Max_Entry_Queue_Length,
|
|
111
|
576 Aspect_Max_Queue_Length => Aspect_Max_Queue_Length,
|
|
145
|
577 Aspect_No_Caching => Aspect_No_Caching,
|
|
111
|
578 Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
|
|
|
579 Aspect_No_Inline => Aspect_No_Inline,
|
|
|
580 Aspect_No_Return => Aspect_No_Return,
|
|
|
581 Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams,
|
|
|
582 Aspect_Obsolescent => Aspect_Obsolescent,
|
|
|
583 Aspect_Object_Size => Aspect_Object_Size,
|
|
|
584 Aspect_Output => Aspect_Output,
|
|
|
585 Aspect_Pack => Aspect_Pack,
|
|
|
586 Aspect_Part_Of => Aspect_Part_Of,
|
|
|
587 Aspect_Persistent_BSS => Aspect_Persistent_BSS,
|
|
|
588 Aspect_Post => Aspect_Post,
|
|
|
589 Aspect_Postcondition => Aspect_Post,
|
|
|
590 Aspect_Pre => Aspect_Pre,
|
|
|
591 Aspect_Precondition => Aspect_Pre,
|
|
|
592 Aspect_Predicate => Aspect_Predicate,
|
|
|
593 Aspect_Predicate_Failure => Aspect_Predicate_Failure,
|
|
|
594 Aspect_Preelaborate => Aspect_Preelaborate,
|
|
|
595 Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
|
|
|
596 Aspect_Priority => Aspect_Priority,
|
|
|
597 Aspect_Pure => Aspect_Pure,
|
|
|
598 Aspect_Pure_Function => Aspect_Pure_Function,
|
|
|
599 Aspect_Refined_Depends => Aspect_Refined_Depends,
|
|
|
600 Aspect_Refined_Global => Aspect_Refined_Global,
|
|
|
601 Aspect_Refined_Post => Aspect_Refined_Post,
|
|
|
602 Aspect_Refined_State => Aspect_Refined_State,
|
|
|
603 Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,
|
|
|
604 Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
|
|
|
605 Aspect_Remote_Types => Aspect_Remote_Types,
|
|
|
606 Aspect_Read => Aspect_Read,
|
|
|
607 Aspect_Relative_Deadline => Aspect_Relative_Deadline,
|
|
|
608 Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order,
|
|
|
609 Aspect_Secondary_Stack_Size => Aspect_Secondary_Stack_Size,
|
|
|
610 Aspect_Shared => Aspect_Atomic,
|
|
|
611 Aspect_Shared_Passive => Aspect_Shared_Passive,
|
|
|
612 Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
|
|
|
613 Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type,
|
|
|
614 Aspect_Size => Aspect_Size,
|
|
|
615 Aspect_Small => Aspect_Small,
|
|
|
616 Aspect_SPARK_Mode => Aspect_SPARK_Mode,
|
|
|
617 Aspect_Static_Predicate => Aspect_Predicate,
|
|
|
618 Aspect_Storage_Pool => Aspect_Storage_Pool,
|
|
|
619 Aspect_Storage_Size => Aspect_Storage_Size,
|
|
|
620 Aspect_Stream_Size => Aspect_Stream_Size,
|
|
|
621 Aspect_Suppress => Aspect_Suppress,
|
|
|
622 Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info,
|
|
|
623 Aspect_Suppress_Initialization => Aspect_Suppress_Initialization,
|
|
|
624 Aspect_Synchronization => Aspect_Synchronization,
|
|
|
625 Aspect_Test_Case => Aspect_Test_Case,
|
|
|
626 Aspect_Thread_Local_Storage => Aspect_Thread_Local_Storage,
|
|
|
627 Aspect_Type_Invariant => Aspect_Invariant,
|
|
|
628 Aspect_Unchecked_Union => Aspect_Unchecked_Union,
|
|
|
629 Aspect_Unimplemented => Aspect_Unimplemented,
|
|
|
630 Aspect_Universal_Aliasing => Aspect_Universal_Aliasing,
|
|
|
631 Aspect_Universal_Data => Aspect_Universal_Data,
|
|
|
632 Aspect_Unmodified => Aspect_Unmodified,
|
|
|
633 Aspect_Unreferenced => Aspect_Unreferenced,
|
|
|
634 Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects,
|
|
|
635 Aspect_Unsuppress => Aspect_Unsuppress,
|
|
|
636 Aspect_Variable_Indexing => Aspect_Variable_Indexing,
|
|
|
637 Aspect_Value_Size => Aspect_Value_Size,
|
|
|
638 Aspect_Volatile => Aspect_Volatile,
|
|
|
639 Aspect_Volatile_Components => Aspect_Volatile_Components,
|
|
|
640 Aspect_Volatile_Full_Access => Aspect_Volatile_Full_Access,
|
|
|
641 Aspect_Volatile_Function => Aspect_Volatile_Function,
|
|
|
642 Aspect_Warnings => Aspect_Warnings,
|
|
|
643 Aspect_Write => Aspect_Write);
|
|
|
644
|
|
|
645 function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean is
|
|
|
646 begin
|
|
|
647 return Canonical_Aspect (A1) = Canonical_Aspect (A2);
|
|
|
648 end Same_Aspect;
|
|
|
649
|
|
|
650 -------------------------------
|
|
|
651 -- Set_Aspect_Specifications --
|
|
|
652 -------------------------------
|
|
|
653
|
|
|
654 procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
|
|
|
655 begin
|
|
|
656 pragma Assert (Permits_Aspect_Specifications (N));
|
|
|
657 pragma Assert (not Has_Aspects (N));
|
|
|
658 pragma Assert (L /= No_List);
|
|
|
659
|
|
|
660 Set_Has_Aspects (N);
|
|
|
661 Set_Parent (L, N);
|
|
|
662 Aspect_Specifications_Hash_Table.Set (N, L);
|
|
|
663 end Set_Aspect_Specifications;
|
|
|
664
|
|
|
665 ----------------------------------------
|
|
|
666 -- Set_Aspect_Specifications_No_Check --
|
|
|
667 ----------------------------------------
|
|
|
668
|
|
|
669 procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id) is
|
|
|
670 begin
|
|
|
671 pragma Assert (Permits_Aspect_Specifications (N));
|
|
|
672 pragma Assert (L /= No_List);
|
|
|
673
|
|
|
674 Set_Has_Aspects (N);
|
|
|
675 Set_Parent (L, N);
|
|
|
676 Aspect_Specifications_Hash_Table.Set (N, L);
|
|
|
677 end Set_Aspect_Specifications_No_Check;
|
|
|
678
|
|
|
679 ---------------
|
|
|
680 -- Tree_Read --
|
|
|
681 ---------------
|
|
|
682
|
|
|
683 procedure Tree_Read is
|
|
|
684 Node : Node_Id;
|
|
|
685 List : List_Id;
|
|
|
686 begin
|
|
|
687 loop
|
|
|
688 Tree_Read_Int (Int (Node));
|
|
|
689 Tree_Read_Int (Int (List));
|
|
|
690 exit when List = No_List;
|
|
|
691 Set_Aspect_Specifications_No_Check (Node, List);
|
|
|
692 end loop;
|
|
|
693 end Tree_Read;
|
|
|
694
|
|
|
695 ----------------
|
|
|
696 -- Tree_Write --
|
|
|
697 ----------------
|
|
|
698
|
|
|
699 procedure Tree_Write is
|
|
|
700 Node : Node_Id := Empty;
|
|
|
701 List : List_Id;
|
|
|
702 begin
|
|
|
703 Aspect_Specifications_Hash_Table.Get_First (Node, List);
|
|
|
704 loop
|
|
|
705 Tree_Write_Int (Int (Node));
|
|
|
706 Tree_Write_Int (Int (List));
|
|
|
707 exit when List = No_List;
|
|
|
708 Aspect_Specifications_Hash_Table.Get_Next (Node, List);
|
|
|
709 end loop;
|
|
|
710 end Tree_Write;
|
|
|
711
|
|
|
712 -- Package initialization sets up Aspect Id hash table
|
|
|
713
|
|
|
714 begin
|
|
|
715 for J in Aspect_Id loop
|
|
|
716 Aspect_Id_Hash_Table.Set (Aspect_Names (J), J);
|
|
|
717 end loop;
|
|
|
718 end Aspects;
|
