1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
|
------------------------------------------------------------------------------
-- --
-- GNATCHECK COMPONENTS --
-- --
-- G N A T S Y N C . G L O B A L _ I N F O . D A T A _ O B J E C T S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2007-2010, AdaCore --
-- --
-- GNATSYNC is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 2, or ( at your option) any later --
-- version. GNATCHECK is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details. You should have received a copy of the --
-- GNU General Public License distributed with GNAT; see file COPYING. If --
-- not, write to the Free Software Foundation, 51 Franklin Street, Fifth --
-- Floor, Boston, MA 02110-1301, USA. --
-- --
-- GNATSYNC is maintained by AdaCore (http://www.adacore.com). --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Asis.Declarations; use Asis.Declarations;
with Asis.Elements; use Asis.Elements;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Expressions; use Asis.Expressions;
with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds;
with Asis.Statements; use Asis.Statements;
with Asis.Set_Get; use Asis.Set_Get;
with Atree; use Atree;
with Sinfo; use Sinfo;
with Einfo; use Einfo;
with ASIS_UL.Strings; use ASIS_UL.Strings;
with ASIS_UL.Utilities; use ASIS_UL.Utilities;
with Gnatsync.ASIS_Utilities; use Gnatsync.ASIS_Utilities;
package body Gnatsync.Global_Info.Data_Objects is
------------------------
-- Local subprograms --
------------------------
function Get_Reference_Kind
(Identifier : Asis.Element)
return Reference_Kinds;
-- Checks if Identifier (that is supposed to be An_Identifier) Element is
-- read, write or read-write reference. Returns Not_A_Reference if
-- Identifier is not of An_Identifier kind.
--
-- This function does not check if Identifier is indeed a reference to a
-- data object, this should be checked before the call.
-------------------------------
-- Check_If_Global_Reference --
-------------------------------
procedure Check_If_Global_Reference
(Element : Asis.Element;
Definition : out Asis.Element;
Is_Global_Reference : out Boolean;
Can_Be_Accessed_By_Local_Task : out Boolean;
Reference_Kind : out Reference_Kinds;
Compute_Reference_Kind : Boolean := False)
is
Tmp : Asis.Element;
begin
-- This implementation does not care very much about performance...
Is_Global_Reference := False;
Can_Be_Accessed_By_Local_Task := False;
Reference_Kind := Not_A_Reference;
begin
Definition := Corresponding_Name_Definition (Element);
exception
when ASIS_Inappropriate_Element =>
-- El is definitely not a reference to a variable!
return;
end;
if Defining_Name_Kind (Definition) /= A_Defining_Identifier
or else
Nkind (Node (Definition)) /= N_Defining_Identifier -- statememt names
or else
Ekind (Node (Definition)) /= E_Variable
then
-- This is also not a variable reference for sure
return;
end if;
Tmp := Enclosing_Element (Definition);
case Declaration_Kind (Tmp) is
when A_Variable_Declaration =>
if not (Is_Concurrent (Definition)
-- We do not count references to task or protected objects.
or else
Is_Volatile (Definition)
or else
Is_Atomic (Definition)
or else
Is_Reference_To_Councurrent_Component (Element))
then
Is_Global_Reference :=
(Is_Global_For_Current_Scope (Definition));
if not Is_Global_Reference then
Can_Be_Accessed_By_Local_Task :=
Can_Be_Accessed_By_Enclosed_Tasks (Tmp);
end if;
end if;
when An_Object_Renaming_Declaration =>
-- We have to unwind the renaming in order to detect what data
-- object is really referenced. There are two specal situations
-- here:
--
-- 1. The renamed object is a function call or a component
-- thereof. In this case we have a constant declaration, we
-- do not store this as a reference.
--
-- 2. When unwinding renamings, we may go through some access
-- value(s). But here we do not care about indirect access
-- through the access values, the corresponding diagnostic
-- should be generated separately.
-- We have to unwind renaming by recursive calls to this
-- procedure, because Corresponding_Base_Entity stops if the
-- renaming object is a component of another object
Tmp := Corresponding_Base_Entity (Tmp);
case Expression_Kind (Tmp) is
when An_Identifier =>
null;
when An_Explicit_Dereference |
An_Indexed_Component |
A_Slice |
An_Attribute_Reference =>
Tmp := Prefix (Tmp);
when A_Type_Conversion =>
Tmp := Converted_Or_Qualified_Expression (Tmp);
when A_Selected_Component =>
-- In case of A.B we may have a component of A or an
-- expanded name of B
if Is_Component (Tmp) then
Tmp := Prefix (Tmp);
else
Tmp := Selector (Tmp);
end if;
when others =>
-- Is_Global_Reference is False.
-- Here we have either impossible cases (such as an
-- aggregate) or cases that make this renaming a constant
-- declaration (such as a function call or an enumeration
-- literal). So:
return;
end case;
Check_If_Global_Reference
(Element => Tmp,
Definition => Definition,
Is_Global_Reference => Is_Global_Reference,
Can_Be_Accessed_By_Local_Task => Can_Be_Accessed_By_Local_Task,
Reference_Kind => Reference_Kind);
when A_Constant_Declaration |
-- we care about variables only!
A_Choice_Parameter_Specification |
A_Single_Task_Declaration |
A_Single_Protected_Declaration =>
Is_Global_Reference := False;
when others =>
pragma Assert (False);
null;
end case;
if (Is_Global_Reference
or else
Can_Be_Accessed_By_Local_Task)
and then
Compute_Reference_Kind
then
Reference_Kind := Get_Reference_Kind (Element);
end if;
end Check_If_Global_Reference;
------------------------
-- Get_Reference_Kind --
------------------------
function Get_Reference_Kind
(Identifier : Asis.Element)
return Reference_Kinds
is
Result : Reference_Kinds := Not_A_Reference;
Enclosing : Asis.Element;
Enclosing_Old : Asis.Element := Identifier;
-- When going up the ASIS tree,
-- Enclosing = Enclosing_Element (Enclosing_Old)
begin
if Expression_Kind (Identifier) = An_Identifier then
Enclosing := Enclosing_Element (Enclosing_Old);
loop
case Flat_Element_Kind (Enclosing) is
when An_Assignment_Statement =>
if Is_Equal
(Enclosing_Old, Assignment_Variable_Name (Enclosing))
then
Result := Write;
else
Result := Read;
end if;
exit;
when A_Parameter_Association =>
Enclosing_Old := Enclosing;
Enclosing := Enclosing_Element (Enclosing_Old);
if Expression_Kind (Enclosing) = A_Function_Call then
Result := Read;
elsif Expression_Kind (Called_Name (Enclosing)) =
An_Attribute_Reference
then
Result := Read;
else
Enclosing := Get_Parameter_Declaration (Enclosing_Old);
case Mode_Kind (Enclosing) is
when A_Default_In_Mode |
An_In_Mode =>
Result := Read;
when An_Out_Mode =>
Result := Write;
when An_In_Out_Mode =>
Result := Read_Write;
when others =>
null;
pragma Assert (False);
end case;
end if;
exit;
when Flat_Expression_Kinds =>
case Expression_Kind (Enclosing) is
when An_Attribute_Reference =>
if Attribute_Kind (Enclosing) = An_Access_Attribute
or else
(Attribute_Kind (Enclosing) =
An_Implementation_Defined_Attribute
and then
To_Lower (To_String
(Name_Image
(Attribute_Designator_Identifier
(Enclosing)))) =
"unrestricted_access")
then
-- An access value pointing to this object is
-- created, we have no idea how it is used, so:
Result := Read_Write;
else
-- For all other cases related to attributes, only
-- read access is possible
Result := Read;
end if;
exit;
when An_Indexed_Component =>
-- If is is an index value - it is a read access
if not Is_Equal
(Prefix (Enclosing), Enclosing_Old)
then
Result := Read;
exit;
end if;
when A_Function_Call =>
Result := Read;
exit;
when others =>
-- Continue bottom-up traversal...
null;
end case;
when others =>
Result := Read;
exit;
end case;
Enclosing_Old := Enclosing;
Enclosing := Enclosing_Element (Enclosing_Old);
end loop;
end if;
pragma Warnings (Off);
return Result;
pragma Warnings (On);
end Get_Reference_Kind;
------------------------------
-- Process_Global_Reference --
------------------------------
procedure Process_Global_Reference
(Element : Asis.Element;
Definition : Asis.Element;
Reference_Kind : Reference_Kinds;
Local_Var_Accessed_By_Local_Tasks : Boolean)
is
Def_Node : constant GS_Node_Id := Corresponding_Node (Definition);
begin
pragma Assert (Present (Def_Node));
pragma Assert (Reference_Kind /= Not_A_Reference);
if Local_Var_Accessed_By_Local_Tasks then
Set_Is_Local_Var_Accessed_By_Local_Tasks (Def_Node);
end if;
Store_Reference
(N => Def_Node,
At_SLOC => Build_GNAT_Location (Element),
Reference_Kind => Reference_Kind);
end Process_Global_Reference;
end Gnatsync.Global_Info.Data_Objects;
|
