|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- P A R _ S C O --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2009-2018, 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. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Aspects; use Aspects;
|
|
|
27 with Atree; use Atree;
|
|
|
28 with Debug; use Debug;
|
|
|
29 with Errout; use Errout;
|
|
|
30 with Lib; use Lib;
|
|
|
31 with Lib.Util; use Lib.Util;
|
|
|
32 with Namet; use Namet;
|
|
|
33 with Nlists; use Nlists;
|
|
|
34 with Opt; use Opt;
|
|
|
35 with Output; use Output;
|
|
|
36 with Put_SCOs;
|
|
|
37 with SCOs; use SCOs;
|
|
|
38 with Sem; use Sem;
|
|
|
39 with Sem_Util; use Sem_Util;
|
|
|
40 with Sinfo; use Sinfo;
|
|
|
41 with Sinput; use Sinput;
|
|
|
42 with Snames; use Snames;
|
|
|
43 with Table;
|
|
|
44
|
|
|
45 with GNAT.HTable; use GNAT.HTable;
|
|
|
46 with GNAT.Heap_Sort_G;
|
|
|
47
|
|
|
48 package body Par_SCO is
|
|
|
49
|
|
|
50 --------------------------
|
|
|
51 -- First-pass SCO table --
|
|
|
52 --------------------------
|
|
|
53
|
|
|
54 -- The Short_Circuit_And_Or pragma enables one to use AND and OR operators
|
|
|
55 -- in source code while the ones used with booleans will be interpreted as
|
|
|
56 -- their short circuit alternatives (AND THEN and OR ELSE). Thus, the true
|
|
|
57 -- meaning of these operators is known only after the semantic analysis.
|
|
|
58
|
|
|
59 -- However, decision SCOs include short circuit operators only. The SCO
|
|
|
60 -- information generation pass must be done before expansion, hence before
|
|
|
61 -- the semantic analysis. Because of this, the SCO information generation
|
|
|
62 -- is done in two passes.
|
|
|
63
|
|
|
64 -- The first one (SCO_Record_Raw, before semantic analysis) completes the
|
|
|
65 -- SCO_Raw_Table assuming all AND/OR operators are short circuit ones.
|
|
|
66 -- Then, the semantic analysis determines which operators are promoted to
|
|
|
67 -- short circuit ones. Finally, the second pass (SCO_Record_Filtered)
|
|
|
68 -- translates the SCO_Raw_Table to SCO_Table, taking care of removing the
|
|
|
69 -- remaining AND/OR operators and of adjusting decisions accordingly
|
|
|
70 -- (splitting decisions, removing empty ones, etc.).
|
|
|
71
|
|
|
72 type SCO_Generation_State_Type is (None, Raw, Filtered);
|
|
|
73 SCO_Generation_State : SCO_Generation_State_Type := None;
|
|
|
74 -- Keep track of the SCO generation state: this will prevent us from
|
|
|
75 -- running some steps multiple times (the second pass has to be started
|
|
|
76 -- from multiple places).
|
|
|
77
|
|
|
78 package SCO_Raw_Table is new Table.Table
|
|
|
79 (Table_Component_Type => SCO_Table_Entry,
|
|
|
80 Table_Index_Type => Nat,
|
|
|
81 Table_Low_Bound => 1,
|
|
|
82 Table_Initial => 500,
|
|
|
83 Table_Increment => 300,
|
|
|
84 Table_Name => "Raw_Table");
|
|
|
85
|
|
|
86 -----------------------
|
|
|
87 -- Unit Number Table --
|
|
|
88 -----------------------
|
|
|
89
|
|
|
90 -- This table parallels the SCO_Unit_Table, keeping track of the unit
|
|
|
91 -- numbers corresponding to the entries made in this table, so that before
|
|
|
92 -- writing out the SCO information to the ALI file, we can fill in the
|
|
|
93 -- proper dependency numbers and file names.
|
|
|
94
|
|
|
95 -- Note that the zero'th entry is here for convenience in sorting the
|
|
|
96 -- table, the real lower bound is 1.
|
|
|
97
|
|
|
98 package SCO_Unit_Number_Table is new Table.Table
|
|
|
99 (Table_Component_Type => Unit_Number_Type,
|
|
|
100 Table_Index_Type => SCO_Unit_Index,
|
|
|
101 Table_Low_Bound => 0, -- see note above on sort
|
|
|
102 Table_Initial => 20,
|
|
|
103 Table_Increment => 200,
|
|
|
104 Table_Name => "SCO_Unit_Number_Entry");
|
|
|
105
|
|
|
106 ------------------------------------------
|
|
|
107 -- Condition/Operator/Pragma Hash Table --
|
|
|
108 ------------------------------------------
|
|
|
109
|
|
|
110 -- We need to be able to get to conditions quickly for handling the calls
|
|
|
111 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
|
|
|
112 -- handle calls to Set_SCO_Pragma_Enabled (the same holds for operators and
|
|
|
113 -- Set_SCO_Logical_Operator). For this purpose we identify the conditions,
|
|
|
114 -- operators and pragmas in the table by their starting sloc, and use this
|
|
|
115 -- hash table to map from these sloc values to SCO_Table indexes.
|
|
|
116
|
|
|
117 type Header_Num is new Integer range 0 .. 996;
|
|
|
118 -- Type for hash table headers
|
|
|
119
|
|
|
120 function Hash (F : Source_Ptr) return Header_Num;
|
|
|
121 -- Function to Hash source pointer value
|
|
|
122
|
|
|
123 function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean;
|
|
|
124 -- Function to test two keys for equality
|
|
|
125
|
|
|
126 function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean;
|
|
|
127 -- Function to test for source locations order
|
|
|
128
|
|
|
129 package SCO_Raw_Hash_Table is new Simple_HTable
|
|
|
130 (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
|
|
|
131 -- The actual hash table
|
|
|
132
|
|
|
133 --------------------------
|
|
|
134 -- Internal Subprograms --
|
|
|
135 --------------------------
|
|
|
136
|
|
|
137 function Has_Decision (N : Node_Id) return Boolean;
|
|
|
138 -- N is the node for a subexpression. Returns True if the subexpression
|
|
|
139 -- contains a nested decision (i.e. either is a logical operator, or
|
|
|
140 -- contains a logical operator in its subtree).
|
|
|
141 --
|
|
|
142 -- This must be used in the first pass (SCO_Record_Raw) only: here AND/OR
|
|
|
143 -- operators are considered as short circuit, just in case the
|
|
|
144 -- Short_Circuit_And_Or pragma is used: only real short circuit operations
|
|
|
145 -- will be kept in the secord pass.
|
|
|
146
|
|
|
147 type Tristate is (False, True, Unknown);
|
|
|
148
|
|
|
149 function Is_Logical_Operator (N : Node_Id) return Tristate;
|
|
|
150 -- N is the node for a subexpression. This procedure determines whether N
|
|
|
151 -- is a logical operator: True for short circuit conditions, Unknown for OR
|
|
|
152 -- and AND (the Short_Circuit_And_Or pragma may be used) and False
|
|
|
153 -- otherwise. Note that in cases where True is returned, callers assume
|
|
|
154 -- Nkind (N) in N_Op.
|
|
|
155
|
|
|
156 function To_Source_Location (S : Source_Ptr) return Source_Location;
|
|
|
157 -- Converts Source_Ptr value to Source_Location (line/col) format
|
|
|
158
|
|
|
159 procedure Process_Decisions
|
|
|
160 (N : Node_Id;
|
|
|
161 T : Character;
|
|
|
162 Pragma_Sloc : Source_Ptr);
|
|
|
163 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
|
|
|
164 -- to output any decisions it contains. T is one of IEGPWX (for context of
|
|
|
165 -- expression: if/exit when/entry guard/pragma/while/expression). If T is
|
|
|
166 -- other than X, the node N is the if expression involved, and a decision
|
|
|
167 -- is always present (at the very least a simple decision is present at the
|
|
|
168 -- top level).
|
|
|
169
|
|
|
170 procedure Process_Decisions
|
|
|
171 (L : List_Id;
|
|
|
172 T : Character;
|
|
|
173 Pragma_Sloc : Source_Ptr);
|
|
|
174 -- Calls above procedure for each element of the list L
|
|
|
175
|
|
|
176 procedure Set_Raw_Table_Entry
|
|
|
177 (C1 : Character;
|
|
|
178 C2 : Character;
|
|
|
179 From : Source_Ptr;
|
|
|
180 To : Source_Ptr;
|
|
|
181 Last : Boolean;
|
|
|
182 Pragma_Sloc : Source_Ptr := No_Location;
|
|
|
183 Pragma_Aspect_Name : Name_Id := No_Name);
|
|
|
184 -- Append an entry to SCO_Raw_Table with fields set as per arguments
|
|
|
185
|
|
|
186 type Dominant_Info is record
|
|
|
187 K : Character;
|
|
|
188 -- F/T/S/E for a valid dominance marker, or ' ' for no dominant
|
|
|
189
|
|
|
190 N : Node_Id;
|
|
|
191 -- Node providing the Sloc(s) for the dominance marker
|
|
|
192 end record;
|
|
|
193 No_Dominant : constant Dominant_Info := (' ', Empty);
|
|
|
194
|
|
|
195 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr);
|
|
|
196 -- Add one entry from the instance table to the corresponding SCO table
|
|
|
197
|
|
|
198 procedure Traverse_Declarations_Or_Statements
|
|
|
199 (L : List_Id;
|
|
|
200 D : Dominant_Info := No_Dominant;
|
|
|
201 P : Node_Id := Empty);
|
|
|
202 -- Process L, a list of statements or declarations dominated by D. If P is
|
|
|
203 -- present, it is processed as though it had been prepended to L.
|
|
|
204
|
|
|
205 function Traverse_Declarations_Or_Statements
|
|
|
206 (L : List_Id;
|
|
|
207 D : Dominant_Info := No_Dominant;
|
|
|
208 P : Node_Id := Empty) return Dominant_Info;
|
|
|
209 -- Same as above, and returns dominant information corresponding to the
|
|
|
210 -- last node with SCO in L.
|
|
|
211
|
|
|
212 -- The following Traverse_* routines perform appropriate calls to
|
|
|
213 -- Traverse_Declarations_Or_Statements to traverse specific node kinds.
|
|
|
214 -- Parameter D, when present, indicates the dominant of the first
|
|
|
215 -- declaration or statement within N.
|
|
|
216
|
|
|
217 -- Why is Traverse_Sync_Definition commented specifically, whereas
|
|
|
218 -- the others are not???
|
|
|
219
|
|
|
220 procedure Traverse_Generic_Package_Declaration (N : Node_Id);
|
|
|
221
|
|
|
222 procedure Traverse_Handled_Statement_Sequence
|
|
|
223 (N : Node_Id;
|
|
|
224 D : Dominant_Info := No_Dominant);
|
|
|
225
|
|
|
226 procedure Traverse_Package_Body (N : Node_Id);
|
|
|
227
|
|
|
228 procedure Traverse_Package_Declaration
|
|
|
229 (N : Node_Id;
|
|
|
230 D : Dominant_Info := No_Dominant);
|
|
|
231
|
|
|
232 procedure Traverse_Subprogram_Or_Task_Body
|
|
|
233 (N : Node_Id;
|
|
|
234 D : Dominant_Info := No_Dominant);
|
|
|
235
|
|
|
236 procedure Traverse_Sync_Definition (N : Node_Id);
|
|
|
237 -- Traverse a protected definition or task definition
|
|
|
238
|
|
|
239 -- Note regarding traversals: In a few cases where an Alternatives list is
|
|
|
240 -- involved, pragmas such as "pragma Page" may show up before the first
|
|
|
241 -- alternative. We skip them because we're out of statement or declaration
|
|
|
242 -- context, so these can't be pragmas of interest for SCO purposes, and
|
|
|
243 -- the regular alternative processing typically involves attribute queries
|
|
|
244 -- which aren't valid for a pragma.
|
|
|
245
|
|
|
246 procedure Write_SCOs_To_ALI_File is new Put_SCOs;
|
|
|
247 -- Write SCO information to the ALI file using routines in Lib.Util
|
|
|
248
|
|
|
249 ----------
|
|
|
250 -- dsco --
|
|
|
251 ----------
|
|
|
252
|
|
|
253 procedure dsco is
|
|
|
254 procedure Dump_Entry (Index : Nat; T : SCO_Table_Entry);
|
|
|
255 -- Dump a SCO table entry
|
|
|
256
|
|
|
257 ----------------
|
|
|
258 -- Dump_Entry --
|
|
|
259 ----------------
|
|
|
260
|
|
|
261 procedure Dump_Entry (Index : Nat; T : SCO_Table_Entry) is
|
|
|
262 begin
|
|
|
263 Write_Str (" ");
|
|
|
264 Write_Int (Index);
|
|
|
265 Write_Char ('.');
|
|
|
266
|
|
|
267 if T.C1 /= ' ' then
|
|
|
268 Write_Str (" C1 = '");
|
|
|
269 Write_Char (T.C1);
|
|
|
270 Write_Char (''');
|
|
|
271 end if;
|
|
|
272
|
|
|
273 if T.C2 /= ' ' then
|
|
|
274 Write_Str (" C2 = '");
|
|
|
275 Write_Char (T.C2);
|
|
|
276 Write_Char (''');
|
|
|
277 end if;
|
|
|
278
|
|
|
279 if T.From /= No_Source_Location then
|
|
|
280 Write_Str (" From = ");
|
|
|
281 Write_Int (Int (T.From.Line));
|
|
|
282 Write_Char (':');
|
|
|
283 Write_Int (Int (T.From.Col));
|
|
|
284 end if;
|
|
|
285
|
|
|
286 if T.To /= No_Source_Location then
|
|
|
287 Write_Str (" To = ");
|
|
|
288 Write_Int (Int (T.To.Line));
|
|
|
289 Write_Char (':');
|
|
|
290 Write_Int (Int (T.To.Col));
|
|
|
291 end if;
|
|
|
292
|
|
|
293 if T.Last then
|
|
|
294 Write_Str (" True");
|
|
|
295 else
|
|
|
296 Write_Str (" False");
|
|
|
297 end if;
|
|
|
298
|
|
|
299 Write_Eol;
|
|
|
300 end Dump_Entry;
|
|
|
301
|
|
|
302 -- Start of processing for dsco
|
|
|
303
|
|
|
304 begin
|
|
|
305 -- Dump SCO unit table
|
|
|
306
|
|
|
307 Write_Line ("SCO Unit Table");
|
|
|
308 Write_Line ("--------------");
|
|
|
309
|
|
|
310 for Index in 1 .. SCO_Unit_Table.Last loop
|
|
|
311 declare
|
|
|
312 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
|
|
|
313
|
|
|
314 begin
|
|
|
315 Write_Str (" ");
|
|
|
316 Write_Int (Int (Index));
|
|
|
317 Write_Str (" Dep_Num = ");
|
|
|
318 Write_Int (Int (UTE.Dep_Num));
|
|
|
319 Write_Str (" From = ");
|
|
|
320 Write_Int (Int (UTE.From));
|
|
|
321 Write_Str (" To = ");
|
|
|
322 Write_Int (Int (UTE.To));
|
|
|
323
|
|
|
324 Write_Str (" File_Name = """);
|
|
|
325
|
|
|
326 if UTE.File_Name /= null then
|
|
|
327 Write_Str (UTE.File_Name.all);
|
|
|
328 end if;
|
|
|
329
|
|
|
330 Write_Char ('"');
|
|
|
331 Write_Eol;
|
|
|
332 end;
|
|
|
333 end loop;
|
|
|
334
|
|
|
335 -- Dump SCO Unit number table if it contains any entries
|
|
|
336
|
|
|
337 if SCO_Unit_Number_Table.Last >= 1 then
|
|
|
338 Write_Eol;
|
|
|
339 Write_Line ("SCO Unit Number Table");
|
|
|
340 Write_Line ("---------------------");
|
|
|
341
|
|
|
342 for Index in 1 .. SCO_Unit_Number_Table.Last loop
|
|
|
343 Write_Str (" ");
|
|
|
344 Write_Int (Int (Index));
|
|
|
345 Write_Str (". Unit_Number = ");
|
|
|
346 Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
|
|
|
347 Write_Eol;
|
|
|
348 end loop;
|
|
|
349 end if;
|
|
|
350
|
|
|
351 -- Dump SCO raw-table
|
|
|
352
|
|
|
353 Write_Eol;
|
|
|
354 Write_Line ("SCO Raw Table");
|
|
|
355 Write_Line ("---------");
|
|
|
356
|
|
|
357 if SCO_Generation_State = Filtered then
|
|
|
358 Write_Line ("Empty (free'd after second pass)");
|
|
|
359 else
|
|
|
360 for Index in 1 .. SCO_Raw_Table.Last loop
|
|
|
361 Dump_Entry (Index, SCO_Raw_Table.Table (Index));
|
|
|
362 end loop;
|
|
|
363 end if;
|
|
|
364
|
|
|
365 -- Dump SCO table itself
|
|
|
366
|
|
|
367 Write_Eol;
|
|
|
368 Write_Line ("SCO Filtered Table");
|
|
|
369 Write_Line ("---------");
|
|
|
370
|
|
|
371 for Index in 1 .. SCO_Table.Last loop
|
|
|
372 Dump_Entry (Index, SCO_Table.Table (Index));
|
|
|
373 end loop;
|
|
|
374 end dsco;
|
|
|
375
|
|
|
376 -----------
|
|
|
377 -- Equal --
|
|
|
378 -----------
|
|
|
379
|
|
|
380 function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean is
|
|
|
381 begin
|
|
|
382 return F1 = F2;
|
|
|
383 end Equal;
|
|
|
384
|
|
|
385 -------
|
|
|
386 -- < --
|
|
|
387 -------
|
|
|
388
|
|
|
389 function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean is
|
|
|
390 begin
|
|
|
391 return S1.Line < S2.Line
|
|
|
392 or else (S1.Line = S2.Line and then S1.Col < S2.Col);
|
|
|
393 end "<";
|
|
|
394
|
|
|
395 ------------------
|
|
|
396 -- Has_Decision --
|
|
|
397 ------------------
|
|
|
398
|
|
|
399 function Has_Decision (N : Node_Id) return Boolean is
|
|
|
400 function Check_Node (N : Node_Id) return Traverse_Result;
|
|
|
401 -- Determine if Nkind (N) indicates the presence of a decision (i.e. N
|
|
|
402 -- is a logical operator, which is a decision in itself, or an
|
|
|
403 -- IF-expression whose Condition attribute is a decision).
|
|
|
404
|
|
|
405 ----------------
|
|
|
406 -- Check_Node --
|
|
|
407 ----------------
|
|
|
408
|
|
|
409 function Check_Node (N : Node_Id) return Traverse_Result is
|
|
|
410 begin
|
|
|
411 -- If we are not sure this is a logical operator (AND and OR may be
|
|
|
412 -- turned into logical operators with the Short_Circuit_And_Or
|
|
|
413 -- pragma), assume it is. Putative decisions will be discarded if
|
|
|
414 -- needed in the secord pass.
|
|
|
415
|
|
|
416 if Is_Logical_Operator (N) /= False
|
|
|
417 or else Nkind (N) = N_If_Expression
|
|
|
418 then
|
|
|
419 return Abandon;
|
|
|
420 else
|
|
|
421 return OK;
|
|
|
422 end if;
|
|
|
423 end Check_Node;
|
|
|
424
|
|
|
425 function Traverse is new Traverse_Func (Check_Node);
|
|
|
426
|
|
|
427 -- Start of processing for Has_Decision
|
|
|
428
|
|
|
429 begin
|
|
|
430 return Traverse (N) = Abandon;
|
|
|
431 end Has_Decision;
|
|
|
432
|
|
|
433 ----------
|
|
|
434 -- Hash --
|
|
|
435 ----------
|
|
|
436
|
|
|
437 function Hash (F : Source_Ptr) return Header_Num is
|
|
|
438 begin
|
|
|
439 return Header_Num (Nat (F) mod 997);
|
|
|
440 end Hash;
|
|
|
441
|
|
|
442 ----------------
|
|
|
443 -- Initialize --
|
|
|
444 ----------------
|
|
|
445
|
|
|
446 procedure Initialize is
|
|
|
447 begin
|
|
|
448 SCO_Unit_Number_Table.Init;
|
|
|
449
|
|
|
450 -- The SCO_Unit_Number_Table entry with index 0 is intentionally set
|
|
|
451 -- aside to be used as temporary for sorting.
|
|
|
452
|
|
|
453 SCO_Unit_Number_Table.Increment_Last;
|
|
|
454 end Initialize;
|
|
|
455
|
|
|
456 -------------------------
|
|
|
457 -- Is_Logical_Operator --
|
|
|
458 -------------------------
|
|
|
459
|
|
|
460 function Is_Logical_Operator (N : Node_Id) return Tristate is
|
|
|
461 begin
|
|
|
462 if Nkind_In (N, N_And_Then, N_Op_Not, N_Or_Else) then
|
|
|
463 return True;
|
|
|
464 elsif Nkind_In (N, N_Op_And, N_Op_Or) then
|
|
|
465 return Unknown;
|
|
|
466 else
|
|
|
467 return False;
|
|
|
468 end if;
|
|
|
469 end Is_Logical_Operator;
|
|
|
470
|
|
|
471 -----------------------
|
|
|
472 -- Process_Decisions --
|
|
|
473 -----------------------
|
|
|
474
|
|
|
475 -- Version taking a list
|
|
|
476
|
|
|
477 procedure Process_Decisions
|
|
|
478 (L : List_Id;
|
|
|
479 T : Character;
|
|
|
480 Pragma_Sloc : Source_Ptr)
|
|
|
481 is
|
|
|
482 N : Node_Id;
|
|
|
483
|
|
|
484 begin
|
|
|
485 if L /= No_List then
|
|
|
486 N := First (L);
|
|
|
487 while Present (N) loop
|
|
|
488 Process_Decisions (N, T, Pragma_Sloc);
|
|
|
489 Next (N);
|
|
|
490 end loop;
|
|
|
491 end if;
|
|
|
492 end Process_Decisions;
|
|
|
493
|
|
|
494 -- Version taking a node
|
|
|
495
|
|
|
496 Current_Pragma_Sloc : Source_Ptr := No_Location;
|
|
|
497 -- While processing a pragma, this is set to the sloc of the N_Pragma node
|
|
|
498
|
|
|
499 procedure Process_Decisions
|
|
|
500 (N : Node_Id;
|
|
|
501 T : Character;
|
|
|
502 Pragma_Sloc : Source_Ptr)
|
|
|
503 is
|
|
|
504 Mark : Nat;
|
|
|
505 -- This is used to mark the location of a decision sequence in the SCO
|
|
|
506 -- table. We use it for backing out a simple decision in an expression
|
|
|
507 -- context that contains only NOT operators.
|
|
|
508
|
|
|
509 Mark_Hash : Nat;
|
|
|
510 -- Likewise for the putative SCO_Raw_Hash_Table entries: see below
|
|
|
511
|
|
|
512 type Hash_Entry is record
|
|
|
513 Sloc : Source_Ptr;
|
|
|
514 SCO_Index : Nat;
|
|
|
515 end record;
|
|
|
516 -- We must register all conditions/pragmas in SCO_Raw_Hash_Table.
|
|
|
517 -- However we cannot register them in the same time we are adding the
|
|
|
518 -- corresponding SCO entries to the raw table since we may discard them
|
|
|
519 -- later on. So instead we put all putative conditions into Hash_Entries
|
|
|
520 -- (see below) and register them once we are sure we keep them.
|
|
|
521 --
|
|
|
522 -- This data structure holds the conditions/pragmas to register in
|
|
|
523 -- SCO_Raw_Hash_Table.
|
|
|
524
|
|
|
525 package Hash_Entries is new Table.Table
|
|
|
526 (Table_Component_Type => Hash_Entry,
|
|
|
527 Table_Index_Type => Nat,
|
|
|
528 Table_Low_Bound => 1,
|
|
|
529 Table_Initial => 10,
|
|
|
530 Table_Increment => 10,
|
|
|
531 Table_Name => "Hash_Entries");
|
|
|
532 -- Hold temporarily (i.e. free'd before returning) the Hash_Entry before
|
|
|
533 -- they are registered in SCO_Raw_Hash_Table.
|
|
|
534
|
|
|
535 X_Not_Decision : Boolean;
|
|
|
536 -- This flag keeps track of whether a decision sequence in the SCO table
|
|
|
537 -- contains only NOT operators, and is for an expression context (T=X).
|
|
|
538 -- The flag will be set False if T is other than X, or if an operator
|
|
|
539 -- other than NOT is in the sequence.
|
|
|
540
|
|
|
541 procedure Output_Decision_Operand (N : Node_Id);
|
|
|
542 -- The node N is the top level logical operator of a decision, or it is
|
|
|
543 -- one of the operands of a logical operator belonging to a single
|
|
|
544 -- complex decision. This routine outputs the sequence of table entries
|
|
|
545 -- corresponding to the node. Note that we do not process the sub-
|
|
|
546 -- operands to look for further decisions, that processing is done in
|
|
|
547 -- Process_Decision_Operand, because we can't get decisions mixed up in
|
|
|
548 -- the global table. Call has no effect if N is Empty.
|
|
|
549
|
|
|
550 procedure Output_Element (N : Node_Id);
|
|
|
551 -- Node N is an operand of a logical operator that is not itself a
|
|
|
552 -- logical operator, or it is a simple decision. This routine outputs
|
|
|
553 -- the table entry for the element, with C1 set to ' '. Last is set
|
|
|
554 -- False, and an entry is made in the condition hash table.
|
|
|
555
|
|
|
556 procedure Output_Header (T : Character);
|
|
|
557 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
|
|
|
558 -- PRAGMA, and 'X' for the expression case.
|
|
|
559
|
|
|
560 procedure Process_Decision_Operand (N : Node_Id);
|
|
|
561 -- This is called on node N, the top level node of a decision, or on one
|
|
|
562 -- of its operands or suboperands after generating the full output for
|
|
|
563 -- the complex decision. It process the suboperands of the decision
|
|
|
564 -- looking for nested decisions.
|
|
|
565
|
|
|
566 function Process_Node (N : Node_Id) return Traverse_Result;
|
|
|
567 -- Processes one node in the traversal, looking for logical operators,
|
|
|
568 -- and if one is found, outputs the appropriate table entries.
|
|
|
569
|
|
|
570 -----------------------------
|
|
|
571 -- Output_Decision_Operand --
|
|
|
572 -----------------------------
|
|
|
573
|
|
|
574 procedure Output_Decision_Operand (N : Node_Id) is
|
|
|
575 C1 : Character;
|
|
|
576 C2 : Character;
|
|
|
577 -- C1 holds a character that identifies the operation while C2
|
|
|
578 -- indicates whether we are sure (' ') or not ('?') this operation
|
|
|
579 -- belongs to the decision. '?' entries will be filtered out in the
|
|
|
580 -- second (SCO_Record_Filtered) pass.
|
|
|
581
|
|
|
582 L : Node_Id;
|
|
|
583 T : Tristate;
|
|
|
584
|
|
|
585 begin
|
|
|
586 if No (N) then
|
|
|
587 return;
|
|
|
588 end if;
|
|
|
589
|
|
|
590 T := Is_Logical_Operator (N);
|
|
|
591
|
|
|
592 -- Logical operator
|
|
|
593
|
|
|
594 if T /= False then
|
|
|
595 if Nkind (N) = N_Op_Not then
|
|
|
596 C1 := '!';
|
|
|
597 L := Empty;
|
|
|
598
|
|
|
599 else
|
|
|
600 L := Left_Opnd (N);
|
|
|
601
|
|
|
602 if Nkind_In (N, N_Op_Or, N_Or_Else) then
|
|
|
603 C1 := '|';
|
|
|
604 else pragma Assert (Nkind_In (N, N_Op_And, N_And_Then));
|
|
|
605 C1 := '&';
|
|
|
606 end if;
|
|
|
607 end if;
|
|
|
608
|
|
|
609 if T = True then
|
|
|
610 C2 := ' ';
|
|
|
611 else
|
|
|
612 C2 := '?';
|
|
|
613 end if;
|
|
|
614
|
|
|
615 Set_Raw_Table_Entry
|
|
|
616 (C1 => C1,
|
|
|
617 C2 => C2,
|
|
|
618 From => Sloc (N),
|
|
|
619 To => No_Location,
|
|
|
620 Last => False);
|
|
|
621
|
|
|
622 Hash_Entries.Append ((Sloc (N), SCO_Raw_Table.Last));
|
|
|
623
|
|
|
624 Output_Decision_Operand (L);
|
|
|
625 Output_Decision_Operand (Right_Opnd (N));
|
|
|
626
|
|
|
627 -- Not a logical operator
|
|
|
628
|
|
|
629 else
|
|
|
630 Output_Element (N);
|
|
|
631 end if;
|
|
|
632 end Output_Decision_Operand;
|
|
|
633
|
|
|
634 --------------------
|
|
|
635 -- Output_Element --
|
|
|
636 --------------------
|
|
|
637
|
|
|
638 procedure Output_Element (N : Node_Id) is
|
|
|
639 FSloc : Source_Ptr;
|
|
|
640 LSloc : Source_Ptr;
|
|
|
641 begin
|
|
|
642 Sloc_Range (N, FSloc, LSloc);
|
|
|
643 Set_Raw_Table_Entry
|
|
|
644 (C1 => ' ',
|
|
|
645 C2 => 'c',
|
|
|
646 From => FSloc,
|
|
|
647 To => LSloc,
|
|
|
648 Last => False);
|
|
|
649 Hash_Entries.Append ((FSloc, SCO_Raw_Table.Last));
|
|
|
650 end Output_Element;
|
|
|
651
|
|
|
652 -------------------
|
|
|
653 -- Output_Header --
|
|
|
654 -------------------
|
|
|
655
|
|
|
656 procedure Output_Header (T : Character) is
|
|
|
657 Loc : Source_Ptr := No_Location;
|
|
|
658 -- Node whose Sloc is used for the decision
|
|
|
659
|
|
|
660 Nam : Name_Id := No_Name;
|
|
|
661 -- For the case of an aspect, aspect name
|
|
|
662
|
|
|
663 begin
|
|
|
664 case T is
|
|
|
665 when 'I' | 'E' | 'W' | 'a' | 'A' =>
|
|
|
666
|
|
|
667 -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of
|
|
|
668 -- the parent of the expression.
|
|
|
669
|
|
|
670 Loc := Sloc (Parent (N));
|
|
|
671
|
|
|
672 if T = 'a' or else T = 'A' then
|
|
|
673 Nam := Chars (Identifier (Parent (N)));
|
|
|
674 end if;
|
|
|
675
|
|
|
676 when 'G' | 'P' =>
|
|
|
677
|
|
|
678 -- For entry guard, the token sloc is from the N_Entry_Body.
|
|
|
679 -- For PRAGMA, we must get the location from the pragma node.
|
|
|
680 -- Argument N is the pragma argument, and we have to go up
|
|
|
681 -- two levels (through the pragma argument association) to
|
|
|
682 -- get to the pragma node itself. For the guard on a select
|
|
|
683 -- alternative, we do not have access to the token location for
|
|
|
684 -- the WHEN, so we use the first sloc of the condition itself
|
|
|
685 -- (note: we use First_Sloc, not Sloc, because this is what is
|
|
|
686 -- referenced by dominance markers).
|
|
|
687
|
|
|
688 -- Doesn't this requirement of using First_Sloc need to be
|
|
|
689 -- documented in the spec ???
|
|
|
690
|
|
|
691 if Nkind_In (Parent (N), N_Accept_Alternative,
|
|
|
692 N_Delay_Alternative,
|
|
|
693 N_Terminate_Alternative)
|
|
|
694 then
|
|
|
695 Loc := First_Sloc (N);
|
|
|
696 else
|
|
|
697 Loc := Sloc (Parent (Parent (N)));
|
|
|
698 end if;
|
|
|
699
|
|
|
700 when 'X' =>
|
|
|
701
|
|
|
702 -- For an expression, no Sloc
|
|
|
703
|
|
|
704 null;
|
|
|
705
|
|
|
706 -- No other possibilities
|
|
|
707
|
|
|
708 when others =>
|
|
|
709 raise Program_Error;
|
|
|
710 end case;
|
|
|
711
|
|
|
712 Set_Raw_Table_Entry
|
|
|
713 (C1 => T,
|
|
|
714 C2 => ' ',
|
|
|
715 From => Loc,
|
|
|
716 To => No_Location,
|
|
|
717 Last => False,
|
|
|
718 Pragma_Sloc => Pragma_Sloc,
|
|
|
719 Pragma_Aspect_Name => Nam);
|
|
|
720
|
|
|
721 -- For an aspect specification, which will be rewritten into a
|
|
|
722 -- pragma, enter a hash table entry now.
|
|
|
723
|
|
|
724 if T = 'a' then
|
|
|
725 Hash_Entries.Append ((Loc, SCO_Raw_Table.Last));
|
|
|
726 end if;
|
|
|
727 end Output_Header;
|
|
|
728
|
|
|
729 ------------------------------
|
|
|
730 -- Process_Decision_Operand --
|
|
|
731 ------------------------------
|
|
|
732
|
|
|
733 procedure Process_Decision_Operand (N : Node_Id) is
|
|
|
734 begin
|
|
|
735 if Is_Logical_Operator (N) /= False then
|
|
|
736 if Nkind (N) /= N_Op_Not then
|
|
|
737 Process_Decision_Operand (Left_Opnd (N));
|
|
|
738 X_Not_Decision := False;
|
|
|
739 end if;
|
|
|
740
|
|
|
741 Process_Decision_Operand (Right_Opnd (N));
|
|
|
742
|
|
|
743 else
|
|
|
744 Process_Decisions (N, 'X', Pragma_Sloc);
|
|
|
745 end if;
|
|
|
746 end Process_Decision_Operand;
|
|
|
747
|
|
|
748 ------------------
|
|
|
749 -- Process_Node --
|
|
|
750 ------------------
|
|
|
751
|
|
|
752 function Process_Node (N : Node_Id) return Traverse_Result is
|
|
|
753 begin
|
|
|
754 case Nkind (N) is
|
|
|
755
|
|
|
756 -- Logical operators, output table entries and then process
|
|
|
757 -- operands recursively to deal with nested conditions.
|
|
|
758
|
|
|
759 when N_And_Then
|
|
|
760 | N_Op_And
|
|
|
761 | N_Op_Not
|
|
|
762 | N_Op_Or
|
|
|
763 | N_Or_Else
|
|
|
764 =>
|
|
|
765 declare
|
|
|
766 T : Character;
|
|
|
767
|
|
|
768 begin
|
|
|
769 -- If outer level, then type comes from call, otherwise it
|
|
|
770 -- is more deeply nested and counts as X for expression.
|
|
|
771
|
|
|
772 if N = Process_Decisions.N then
|
|
|
773 T := Process_Decisions.T;
|
|
|
774 else
|
|
|
775 T := 'X';
|
|
|
776 end if;
|
|
|
777
|
|
|
778 -- Output header for sequence
|
|
|
779
|
|
|
780 X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
|
|
|
781 Mark := SCO_Raw_Table.Last;
|
|
|
782 Mark_Hash := Hash_Entries.Last;
|
|
|
783 Output_Header (T);
|
|
|
784
|
|
|
785 -- Output the decision
|
|
|
786
|
|
|
787 Output_Decision_Operand (N);
|
|
|
788
|
|
|
789 -- If the decision was in an expression context (T = 'X')
|
|
|
790 -- and contained only NOT operators, then we don't output
|
|
|
791 -- it, so delete it.
|
|
|
792
|
|
|
793 if X_Not_Decision then
|
|
|
794 SCO_Raw_Table.Set_Last (Mark);
|
|
|
795 Hash_Entries.Set_Last (Mark_Hash);
|
|
|
796
|
|
|
797 -- Otherwise, set Last in last table entry to mark end
|
|
|
798
|
|
|
799 else
|
|
|
800 SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True;
|
|
|
801 end if;
|
|
|
802
|
|
|
803 -- Process any embedded decisions
|
|
|
804
|
|
|
805 Process_Decision_Operand (N);
|
|
|
806 return Skip;
|
|
|
807 end;
|
|
|
808
|
|
|
809 -- Case expression
|
|
|
810
|
|
|
811 -- Really hard to believe this is correct given the special
|
|
|
812 -- handling for if expressions below ???
|
|
|
813
|
|
|
814 when N_Case_Expression =>
|
|
|
815 return OK; -- ???
|
|
|
816
|
|
|
817 -- If expression, processed like an if statement
|
|
|
818
|
|
|
819 when N_If_Expression =>
|
|
|
820 declare
|
|
|
821 Cond : constant Node_Id := First (Expressions (N));
|
|
|
822 Thnx : constant Node_Id := Next (Cond);
|
|
|
823 Elsx : constant Node_Id := Next (Thnx);
|
|
|
824
|
|
|
825 begin
|
|
|
826 Process_Decisions (Cond, 'I', Pragma_Sloc);
|
|
|
827 Process_Decisions (Thnx, 'X', Pragma_Sloc);
|
|
|
828 Process_Decisions (Elsx, 'X', Pragma_Sloc);
|
|
|
829 return Skip;
|
|
|
830 end;
|
|
|
831
|
|
|
832 -- All other cases, continue scan
|
|
|
833
|
|
|
834 when others =>
|
|
|
835 return OK;
|
|
|
836 end case;
|
|
|
837 end Process_Node;
|
|
|
838
|
|
|
839 procedure Traverse is new Traverse_Proc (Process_Node);
|
|
|
840
|
|
|
841 -- Start of processing for Process_Decisions
|
|
|
842
|
|
|
843 begin
|
|
|
844 if No (N) then
|
|
|
845 return;
|
|
|
846 end if;
|
|
|
847
|
|
|
848 Hash_Entries.Init;
|
|
|
849
|
|
|
850 -- See if we have simple decision at outer level and if so then
|
|
|
851 -- generate the decision entry for this simple decision. A simple
|
|
|
852 -- decision is a boolean expression (which is not a logical operator
|
|
|
853 -- or short circuit form) appearing as the operand of an IF, WHILE,
|
|
|
854 -- EXIT WHEN, or special PRAGMA construct.
|
|
|
855
|
|
|
856 if T /= 'X' and then Is_Logical_Operator (N) = False then
|
|
|
857 Output_Header (T);
|
|
|
858 Output_Element (N);
|
|
|
859
|
|
|
860 -- Change Last in last table entry to True to mark end of
|
|
|
861 -- sequence, which is this case is only one element long.
|
|
|
862
|
|
|
863 SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True;
|
|
|
864 end if;
|
|
|
865
|
|
|
866 Traverse (N);
|
|
|
867
|
|
|
868 -- Now we have the definitive set of SCO entries, register them in the
|
|
|
869 -- corresponding hash table.
|
|
|
870
|
|
|
871 for J in 1 .. Hash_Entries.Last loop
|
|
|
872 SCO_Raw_Hash_Table.Set
|
|
|
873 (Hash_Entries.Table (J).Sloc,
|
|
|
874 Hash_Entries.Table (J).SCO_Index);
|
|
|
875 end loop;
|
|
|
876
|
|
|
877 Hash_Entries.Free;
|
|
|
878 end Process_Decisions;
|
|
|
879
|
|
|
880 -----------
|
|
|
881 -- pscos --
|
|
|
882 -----------
|
|
|
883
|
|
|
884 procedure pscos is
|
|
|
885 procedure Write_Info_Char (C : Character) renames Write_Char;
|
|
|
886 -- Write one character;
|
|
|
887
|
|
|
888 procedure Write_Info_Initiate (Key : Character) renames Write_Char;
|
|
|
889 -- Start new one and write one character;
|
|
|
890
|
|
|
891 procedure Write_Info_Nat (N : Nat);
|
|
|
892 -- Write value of N
|
|
|
893
|
|
|
894 procedure Write_Info_Terminate renames Write_Eol;
|
|
|
895 -- Terminate current line
|
|
|
896
|
|
|
897 --------------------
|
|
|
898 -- Write_Info_Nat --
|
|
|
899 --------------------
|
|
|
900
|
|
|
901 procedure Write_Info_Nat (N : Nat) is
|
|
|
902 begin
|
|
|
903 Write_Int (N);
|
|
|
904 end Write_Info_Nat;
|
|
|
905
|
|
|
906 procedure Debug_Put_SCOs is new Put_SCOs;
|
|
|
907
|
|
|
908 -- Start of processing for pscos
|
|
|
909
|
|
|
910 begin
|
|
|
911 Debug_Put_SCOs;
|
|
|
912 end pscos;
|
|
|
913
|
|
|
914 ---------------------
|
|
|
915 -- Record_Instance --
|
|
|
916 ---------------------
|
|
|
917
|
|
|
918 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is
|
|
|
919 Inst_Src : constant Source_File_Index :=
|
|
|
920 Get_Source_File_Index (Inst_Sloc);
|
|
|
921 begin
|
|
|
922 SCO_Instance_Table.Append
|
|
|
923 ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)),
|
|
|
924 Inst_Loc => To_Source_Location (Inst_Sloc),
|
|
|
925 Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src))));
|
|
|
926
|
|
|
927 pragma Assert
|
|
|
928 (SCO_Instance_Table.Last = SCO_Instance_Index (Id));
|
|
|
929 end Record_Instance;
|
|
|
930
|
|
|
931 ----------------
|
|
|
932 -- SCO_Output --
|
|
|
933 ----------------
|
|
|
934
|
|
|
935 procedure SCO_Output is
|
|
|
936 procedure Populate_SCO_Instance_Table is
|
|
|
937 new Sinput.Iterate_On_Instances (Record_Instance);
|
|
|
938
|
|
|
939 begin
|
|
|
940 pragma Assert (SCO_Generation_State = Filtered);
|
|
|
941
|
|
|
942 if Debug_Flag_Dot_OO then
|
|
|
943 dsco;
|
|
|
944 end if;
|
|
|
945
|
|
|
946 Populate_SCO_Instance_Table;
|
|
|
947
|
|
|
948 -- Sort the unit tables based on dependency numbers
|
|
|
949
|
|
|
950 Unit_Table_Sort : declare
|
|
|
951 function Lt (Op1 : Natural; Op2 : Natural) return Boolean;
|
|
|
952 -- Comparison routine for sort call
|
|
|
953
|
|
|
954 procedure Move (From : Natural; To : Natural);
|
|
|
955 -- Move routine for sort call
|
|
|
956
|
|
|
957 --------
|
|
|
958 -- Lt --
|
|
|
959 --------
|
|
|
960
|
|
|
961 function Lt (Op1 : Natural; Op2 : Natural) return Boolean is
|
|
|
962 begin
|
|
|
963 return
|
|
|
964 Dependency_Num
|
|
|
965 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
|
|
|
966 <
|
|
|
967 Dependency_Num
|
|
|
968 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
|
|
|
969 end Lt;
|
|
|
970
|
|
|
971 ----------
|
|
|
972 -- Move --
|
|
|
973 ----------
|
|
|
974
|
|
|
975 procedure Move (From : Natural; To : Natural) is
|
|
|
976 begin
|
|
|
977 SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
|
|
|
978 SCO_Unit_Table.Table (SCO_Unit_Index (From));
|
|
|
979 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
|
|
|
980 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
|
|
|
981 end Move;
|
|
|
982
|
|
|
983 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
|
|
|
984
|
|
|
985 -- Start of processing for Unit_Table_Sort
|
|
|
986
|
|
|
987 begin
|
|
|
988 Sorting.Sort (Integer (SCO_Unit_Table.Last));
|
|
|
989 end Unit_Table_Sort;
|
|
|
990
|
|
|
991 -- Loop through entries in the unit table to set file name and
|
|
|
992 -- dependency number entries.
|
|
|
993
|
|
|
994 for J in 1 .. SCO_Unit_Table.Last loop
|
|
|
995 declare
|
|
|
996 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
|
|
|
997 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
|
|
|
998
|
|
|
999 begin
|
|
|
1000 Get_Name_String (Reference_Name (Source_Index (U)));
|
|
|
1001 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
|
|
|
1002 UTE.Dep_Num := Dependency_Num (U);
|
|
|
1003 end;
|
|
|
1004 end loop;
|
|
|
1005
|
|
|
1006 -- Now the tables are all setup for output to the ALI file
|
|
|
1007
|
|
|
1008 Write_SCOs_To_ALI_File;
|
|
|
1009 end SCO_Output;
|
|
|
1010
|
|
|
1011 -------------------------
|
|
|
1012 -- SCO_Pragma_Disabled --
|
|
|
1013 -------------------------
|
|
|
1014
|
|
|
1015 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
|
|
|
1016 Index : Nat;
|
|
|
1017
|
|
|
1018 begin
|
|
|
1019 if Loc = No_Location then
|
|
|
1020 return False;
|
|
|
1021 end if;
|
|
|
1022
|
|
|
1023 Index := SCO_Raw_Hash_Table.Get (Loc);
|
|
|
1024
|
|
|
1025 -- The test here for zero is to deal with possible previous errors, and
|
|
|
1026 -- for the case of pragma statement SCOs, for which we always set the
|
|
|
1027 -- Pragma_Sloc even if the particular pragma cannot be specifically
|
|
|
1028 -- disabled.
|
|
|
1029
|
|
|
1030 if Index /= 0 then
|
|
|
1031 declare
|
|
|
1032 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
|
|
|
1033
|
|
|
1034 begin
|
|
|
1035 case T.C1 is
|
|
|
1036 when 'S' =>
|
|
|
1037 -- Pragma statement
|
|
|
1038
|
|
|
1039 return T.C2 = 'p';
|
|
|
1040
|
|
|
1041 when 'A' =>
|
|
|
1042 -- Aspect decision (enabled)
|
|
|
1043
|
|
|
1044 return False;
|
|
|
1045
|
|
|
1046 when 'a' =>
|
|
|
1047 -- Aspect decision (not enabled)
|
|
|
1048
|
|
|
1049 return True;
|
|
|
1050
|
|
|
1051 when ASCII.NUL =>
|
|
|
1052 -- Nullified disabled SCO
|
|
|
1053
|
|
|
1054 return True;
|
|
|
1055
|
|
|
1056 when others =>
|
|
|
1057 raise Program_Error;
|
|
|
1058 end case;
|
|
|
1059 end;
|
|
|
1060
|
|
|
1061 else
|
|
|
1062 return False;
|
|
|
1063 end if;
|
|
|
1064 end SCO_Pragma_Disabled;
|
|
|
1065
|
|
|
1066 --------------------
|
|
|
1067 -- SCO_Record_Raw --
|
|
|
1068 --------------------
|
|
|
1069
|
|
|
1070 procedure SCO_Record_Raw (U : Unit_Number_Type) is
|
|
|
1071 procedure Traverse_Aux_Decls (N : Node_Id);
|
|
|
1072 -- Traverse the Aux_Decls_Node of compilation unit N
|
|
|
1073
|
|
|
1074 ------------------------
|
|
|
1075 -- Traverse_Aux_Decls --
|
|
|
1076 ------------------------
|
|
|
1077
|
|
|
1078 procedure Traverse_Aux_Decls (N : Node_Id) is
|
|
|
1079 ADN : constant Node_Id := Aux_Decls_Node (N);
|
|
|
1080
|
|
|
1081 begin
|
|
|
1082 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
|
|
|
1083 Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
|
|
|
1084
|
|
|
1085 -- Declarations and Actions do not correspond to source constructs,
|
|
|
1086 -- they contain only nodes from expansion, so at this point they
|
|
|
1087 -- should still be empty:
|
|
|
1088
|
|
|
1089 pragma Assert (No (Declarations (ADN)));
|
|
|
1090 pragma Assert (No (Actions (ADN)));
|
|
|
1091 end Traverse_Aux_Decls;
|
|
|
1092
|
|
|
1093 -- Local variables
|
|
|
1094
|
|
|
1095 From : Nat;
|
|
|
1096 Lu : Node_Id;
|
|
|
1097
|
|
|
1098 -- Start of processing for SCO_Record_Raw
|
|
|
1099
|
|
|
1100 begin
|
|
|
1101 -- It is legitimate to run this pass multiple times (once per unit) so
|
|
|
1102 -- run it even if it was already run before.
|
|
|
1103
|
|
|
1104 pragma Assert (SCO_Generation_State in None .. Raw);
|
|
|
1105 SCO_Generation_State := Raw;
|
|
|
1106
|
|
|
1107 -- Ignore call if not generating code and generating SCO's
|
|
|
1108
|
|
|
1109 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
|
|
|
1110 return;
|
|
|
1111 end if;
|
|
|
1112
|
|
|
1113 -- Ignore call if this unit already recorded
|
|
|
1114
|
|
|
1115 for J in 1 .. SCO_Unit_Number_Table.Last loop
|
|
|
1116 if U = SCO_Unit_Number_Table.Table (J) then
|
|
|
1117 return;
|
|
|
1118 end if;
|
|
|
1119 end loop;
|
|
|
1120
|
|
|
1121 -- Otherwise record starting entry
|
|
|
1122
|
|
|
1123 From := SCO_Raw_Table.Last + 1;
|
|
|
1124
|
|
|
1125 -- Get Unit (checking case of subunit)
|
|
|
1126
|
|
|
1127 Lu := Unit (Cunit (U));
|
|
|
1128
|
|
|
1129 if Nkind (Lu) = N_Subunit then
|
|
|
1130 Lu := Proper_Body (Lu);
|
|
|
1131 end if;
|
|
|
1132
|
|
|
1133 -- Traverse the unit
|
|
|
1134
|
|
|
1135 Traverse_Aux_Decls (Cunit (U));
|
|
|
1136
|
|
|
1137 case Nkind (Lu) is
|
|
|
1138 when N_Generic_Instantiation
|
|
|
1139 | N_Generic_Package_Declaration
|
|
|
1140 | N_Package_Body
|
|
|
1141 | N_Package_Declaration
|
|
|
1142 | N_Protected_Body
|
|
|
1143 | N_Subprogram_Body
|
|
|
1144 | N_Subprogram_Declaration
|
|
|
1145 | N_Task_Body
|
|
|
1146 =>
|
|
|
1147 Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
|
|
|
1148
|
|
|
1149 -- All other cases of compilation units (e.g. renamings), generate no
|
|
|
1150 -- SCO information.
|
|
|
1151
|
|
|
1152 when others =>
|
|
|
1153 null;
|
|
|
1154 end case;
|
|
|
1155
|
|
|
1156 -- Make entry for new unit in unit tables, we will fill in the file
|
|
|
1157 -- name and dependency numbers later.
|
|
|
1158
|
|
|
1159 SCO_Unit_Table.Append (
|
|
|
1160 (Dep_Num => 0,
|
|
|
1161 File_Name => null,
|
|
|
1162 File_Index => Get_Source_File_Index (Sloc (Lu)),
|
|
|
1163 From => From,
|
|
|
1164 To => SCO_Raw_Table.Last));
|
|
|
1165
|
|
|
1166 SCO_Unit_Number_Table.Append (U);
|
|
|
1167 end SCO_Record_Raw;
|
|
|
1168
|
|
|
1169 -----------------------
|
|
|
1170 -- Set_SCO_Condition --
|
|
|
1171 -----------------------
|
|
|
1172
|
|
|
1173 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
|
|
|
1174
|
|
|
1175 -- SCO annotations are not processed after the filtering pass
|
|
|
1176
|
|
|
1177 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
|
|
|
1178
|
|
|
1179 Constant_Condition_Code : constant array (Boolean) of Character :=
|
|
|
1180 (False => 'f', True => 't');
|
|
|
1181
|
|
|
1182 Orig : constant Node_Id := Original_Node (Cond);
|
|
|
1183 Dummy : Source_Ptr;
|
|
|
1184 Index : Nat;
|
|
|
1185 Start : Source_Ptr;
|
|
|
1186
|
|
|
1187 begin
|
|
|
1188 Sloc_Range (Orig, Start, Dummy);
|
|
|
1189 Index := SCO_Raw_Hash_Table.Get (Start);
|
|
|
1190
|
|
|
1191 -- Index can be zero for boolean expressions that do not have SCOs
|
|
|
1192 -- (simple decisions outside of a control flow structure), or in case
|
|
|
1193 -- of a previous error.
|
|
|
1194
|
|
|
1195 if Index = 0 then
|
|
|
1196 return;
|
|
|
1197
|
|
|
1198 else
|
|
|
1199 pragma Assert (SCO_Raw_Table.Table (Index).C1 = ' ');
|
|
|
1200 SCO_Raw_Table.Table (Index).C2 := Constant_Condition_Code (Val);
|
|
|
1201 end if;
|
|
|
1202 end Set_SCO_Condition;
|
|
|
1203
|
|
|
1204 ------------------------------
|
|
|
1205 -- Set_SCO_Logical_Operator --
|
|
|
1206 ------------------------------
|
|
|
1207
|
|
|
1208 procedure Set_SCO_Logical_Operator (Op : Node_Id) is
|
|
|
1209
|
|
|
1210 -- SCO annotations are not processed after the filtering pass
|
|
|
1211
|
|
|
1212 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
|
|
|
1213
|
|
|
1214 Orig : constant Node_Id := Original_Node (Op);
|
|
|
1215 Orig_Sloc : constant Source_Ptr := Sloc (Orig);
|
|
|
1216 Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc);
|
|
|
1217
|
|
|
1218 begin
|
|
|
1219 -- All (putative) logical operators are supposed to have their own entry
|
|
|
1220 -- in the SCOs table. However, the semantic analysis may invoke this
|
|
|
1221 -- subprogram with nodes that are out of the SCO generation scope.
|
|
|
1222
|
|
|
1223 if Index /= 0 then
|
|
|
1224 SCO_Raw_Table.Table (Index).C2 := ' ';
|
|
|
1225 end if;
|
|
|
1226 end Set_SCO_Logical_Operator;
|
|
|
1227
|
|
|
1228 ----------------------------
|
|
|
1229 -- Set_SCO_Pragma_Enabled --
|
|
|
1230 ----------------------------
|
|
|
1231
|
|
|
1232 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
|
|
|
1233
|
|
|
1234 -- SCO annotations are not processed after the filtering pass
|
|
|
1235
|
|
|
1236 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
|
|
|
1237
|
|
|
1238 Index : Nat;
|
|
|
1239
|
|
|
1240 begin
|
|
|
1241 -- Nothing to do if not generating SCO, or if we're not processing the
|
|
|
1242 -- original source occurrence of the pragma.
|
|
|
1243
|
|
|
1244 if not (Generate_SCO
|
|
|
1245 and then In_Extended_Main_Source_Unit (Loc)
|
|
|
1246 and then not (In_Instance or In_Inlined_Body))
|
|
|
1247 then
|
|
|
1248 return;
|
|
|
1249 end if;
|
|
|
1250
|
|
|
1251 -- Note: the reason we use the Sloc value as the key is that in the
|
|
|
1252 -- generic case, the call to this procedure is made on a copy of the
|
|
|
1253 -- original node, so we can't use the Node_Id value.
|
|
|
1254
|
|
|
1255 Index := SCO_Raw_Hash_Table.Get (Loc);
|
|
|
1256
|
|
|
1257 -- A zero index here indicates that semantic analysis found an
|
|
|
1258 -- activated pragma at Loc which does not have a corresponding pragma
|
|
|
1259 -- or aspect at the syntax level. This may occur in legitimate cases
|
|
|
1260 -- because of expanded code (such are Pre/Post conditions generated for
|
|
|
1261 -- formal parameter validity checks), or as a consequence of a previous
|
|
|
1262 -- error.
|
|
|
1263
|
|
|
1264 if Index = 0 then
|
|
|
1265 return;
|
|
|
1266
|
|
|
1267 else
|
|
|
1268 declare
|
|
|
1269 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
|
|
|
1270
|
|
|
1271 begin
|
|
|
1272 -- Note: may be called multiple times for the same sloc, so
|
|
|
1273 -- account for the fact that the entry may already have been
|
|
|
1274 -- marked enabled.
|
|
|
1275
|
|
|
1276 case T.C1 is
|
|
|
1277 -- Aspect (decision SCO)
|
|
|
1278
|
|
|
1279 when 'a' =>
|
|
|
1280 T.C1 := 'A';
|
|
|
1281
|
|
|
1282 when 'A' =>
|
|
|
1283 null;
|
|
|
1284
|
|
|
1285 -- Pragma (statement SCO)
|
|
|
1286
|
|
|
1287 when 'S' =>
|
|
|
1288 pragma Assert (T.C2 = 'p' or else T.C2 = 'P');
|
|
|
1289 T.C2 := 'P';
|
|
|
1290
|
|
|
1291 when others =>
|
|
|
1292 raise Program_Error;
|
|
|
1293 end case;
|
|
|
1294 end;
|
|
|
1295 end if;
|
|
|
1296 end Set_SCO_Pragma_Enabled;
|
|
|
1297
|
|
|
1298 -------------------------
|
|
|
1299 -- Set_Raw_Table_Entry --
|
|
|
1300 -------------------------
|
|
|
1301
|
|
|
1302 procedure Set_Raw_Table_Entry
|
|
|
1303 (C1 : Character;
|
|
|
1304 C2 : Character;
|
|
|
1305 From : Source_Ptr;
|
|
|
1306 To : Source_Ptr;
|
|
|
1307 Last : Boolean;
|
|
|
1308 Pragma_Sloc : Source_Ptr := No_Location;
|
|
|
1309 Pragma_Aspect_Name : Name_Id := No_Name)
|
|
|
1310 is
|
|
|
1311 pragma Assert (SCO_Generation_State = Raw);
|
|
|
1312 begin
|
|
|
1313 SCO_Raw_Table.Append
|
|
|
1314 ((C1 => C1,
|
|
|
1315 C2 => C2,
|
|
|
1316 From => To_Source_Location (From),
|
|
|
1317 To => To_Source_Location (To),
|
|
|
1318 Last => Last,
|
|
|
1319 Pragma_Sloc => Pragma_Sloc,
|
|
|
1320 Pragma_Aspect_Name => Pragma_Aspect_Name));
|
|
|
1321 end Set_Raw_Table_Entry;
|
|
|
1322
|
|
|
1323 ------------------------
|
|
|
1324 -- To_Source_Location --
|
|
|
1325 ------------------------
|
|
|
1326
|
|
|
1327 function To_Source_Location (S : Source_Ptr) return Source_Location is
|
|
|
1328 begin
|
|
|
1329 if S = No_Location then
|
|
|
1330 return No_Source_Location;
|
|
|
1331 else
|
|
|
1332 return
|
|
|
1333 (Line => Get_Logical_Line_Number (S),
|
|
|
1334 Col => Get_Column_Number (S));
|
|
|
1335 end if;
|
|
|
1336 end To_Source_Location;
|
|
|
1337
|
|
|
1338 -----------------------------------------
|
|
|
1339 -- Traverse_Declarations_Or_Statements --
|
|
|
1340 -----------------------------------------
|
|
|
1341
|
|
|
1342 -- Tables used by Traverse_Declarations_Or_Statements for temporarily
|
|
|
1343 -- holding statement and decision entries. These are declared globally
|
|
|
1344 -- since they are shared by recursive calls to this procedure.
|
|
|
1345
|
|
|
1346 type SC_Entry is record
|
|
|
1347 N : Node_Id;
|
|
|
1348 From : Source_Ptr;
|
|
|
1349 To : Source_Ptr;
|
|
|
1350 Typ : Character;
|
|
|
1351 end record;
|
|
|
1352 -- Used to store a single entry in the following table, From:To represents
|
|
|
1353 -- the range of entries in the CS line entry, and typ is the type, with
|
|
|
1354 -- space meaning that no type letter will accompany the entry.
|
|
|
1355
|
|
|
1356 package SC is new Table.Table
|
|
|
1357 (Table_Component_Type => SC_Entry,
|
|
|
1358 Table_Index_Type => Nat,
|
|
|
1359 Table_Low_Bound => 1,
|
|
|
1360 Table_Initial => 1000,
|
|
|
1361 Table_Increment => 200,
|
|
|
1362 Table_Name => "SCO_SC");
|
|
|
1363 -- Used to store statement components for a CS entry to be output as a
|
|
|
1364 -- result of the call to this procedure. SC.Last is the last entry stored,
|
|
|
1365 -- so the current statement sequence is represented by SC_Array (SC_First
|
|
|
1366 -- .. SC.Last), where SC_First is saved on entry to each recursive call to
|
|
|
1367 -- the routine.
|
|
|
1368 --
|
|
|
1369 -- Extend_Statement_Sequence adds an entry to this array, and then
|
|
|
1370 -- Set_Statement_Entry clears the entries starting with SC_First, copying
|
|
|
1371 -- these entries to the main SCO output table. The reason that we do the
|
|
|
1372 -- temporary caching of results in this array is that we want the SCO table
|
|
|
1373 -- entries for a given CS line to be contiguous, and the processing may
|
|
|
1374 -- output intermediate entries such as decision entries.
|
|
|
1375
|
|
|
1376 type SD_Entry is record
|
|
|
1377 Nod : Node_Id;
|
|
|
1378 Lst : List_Id;
|
|
|
1379 Typ : Character;
|
|
|
1380 Plo : Source_Ptr;
|
|
|
1381 end record;
|
|
|
1382 -- Used to store a single entry in the following table. Nod is the node to
|
|
|
1383 -- be searched for decisions for the case of Process_Decisions_Defer with a
|
|
|
1384 -- node argument (with Lst set to No_List. Lst is the list to be searched
|
|
|
1385 -- for decisions for the case of Process_Decisions_Defer with a List
|
|
|
1386 -- argument (in which case Nod is set to Empty). Plo is the sloc of the
|
|
|
1387 -- enclosing pragma, if any.
|
|
|
1388
|
|
|
1389 package SD is new Table.Table
|
|
|
1390 (Table_Component_Type => SD_Entry,
|
|
|
1391 Table_Index_Type => Nat,
|
|
|
1392 Table_Low_Bound => 1,
|
|
|
1393 Table_Initial => 1000,
|
|
|
1394 Table_Increment => 200,
|
|
|
1395 Table_Name => "SCO_SD");
|
|
|
1396 -- Used to store possible decision information. Instead of calling the
|
|
|
1397 -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
|
|
|
1398 -- which simply stores the arguments in this table. Then when we clear
|
|
|
1399 -- out a statement sequence using Set_Statement_Entry, after generating
|
|
|
1400 -- the CS lines for the statements, the entries in this table result in
|
|
|
1401 -- calls to Process_Decision. The reason for doing things this way is to
|
|
|
1402 -- ensure that decisions are output after the CS line for the statements
|
|
|
1403 -- in which the decisions occur.
|
|
|
1404
|
|
|
1405 procedure Traverse_Declarations_Or_Statements
|
|
|
1406 (L : List_Id;
|
|
|
1407 D : Dominant_Info := No_Dominant;
|
|
|
1408 P : Node_Id := Empty)
|
|
|
1409 is
|
|
|
1410 Discard_Dom : Dominant_Info;
|
|
|
1411 pragma Warnings (Off, Discard_Dom);
|
|
|
1412 begin
|
|
|
1413 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P);
|
|
|
1414 end Traverse_Declarations_Or_Statements;
|
|
|
1415
|
|
|
1416 function Traverse_Declarations_Or_Statements
|
|
|
1417 (L : List_Id;
|
|
|
1418 D : Dominant_Info := No_Dominant;
|
|
|
1419 P : Node_Id := Empty) return Dominant_Info
|
|
|
1420 is
|
|
|
1421 Current_Dominant : Dominant_Info := D;
|
|
|
1422 -- Dominance information for the current basic block
|
|
|
1423
|
|
|
1424 Current_Test : Node_Id;
|
|
|
1425 -- Conditional node (N_If_Statement or N_Elsiif being processed
|
|
|
1426
|
|
|
1427 N : Node_Id;
|
|
|
1428
|
|
|
1429 SC_First : constant Nat := SC.Last + 1;
|
|
|
1430 SD_First : constant Nat := SD.Last + 1;
|
|
|
1431 -- Record first entries used in SC/SD at this recursive level
|
|
|
1432
|
|
|
1433 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
|
|
|
1434 -- Extend the current statement sequence to encompass the node N. Typ is
|
|
|
1435 -- the letter that identifies the type of statement/declaration that is
|
|
|
1436 -- being added to the sequence.
|
|
|
1437
|
|
|
1438 procedure Process_Decisions_Defer (N : Node_Id; T : Character);
|
|
|
1439 pragma Inline (Process_Decisions_Defer);
|
|
|
1440 -- This routine is logically the same as Process_Decisions, except that
|
|
|
1441 -- the arguments are saved in the SD table for later processing when
|
|
|
1442 -- Set_Statement_Entry is called, which goes through the saved entries
|
|
|
1443 -- making the corresponding calls to Process_Decision. Note: the
|
|
|
1444 -- enclosing statement must have already been added to the current
|
|
|
1445 -- statement sequence, so that nested decisions are properly
|
|
|
1446 -- identified as such.
|
|
|
1447
|
|
|
1448 procedure Process_Decisions_Defer (L : List_Id; T : Character);
|
|
|
1449 pragma Inline (Process_Decisions_Defer);
|
|
|
1450 -- Same case for list arguments, deferred call to Process_Decisions
|
|
|
1451
|
|
|
1452 procedure Set_Statement_Entry;
|
|
|
1453 -- Output CS entries for all statements saved in table SC, and end the
|
|
|
1454 -- current CS sequence. Then output entries for all decisions nested in
|
|
|
1455 -- these statements, which have been deferred so far.
|
|
|
1456
|
|
|
1457 procedure Traverse_One (N : Node_Id);
|
|
|
1458 -- Traverse one declaration or statement
|
|
|
1459
|
|
|
1460 procedure Traverse_Aspects (N : Node_Id);
|
|
|
1461 -- Helper for Traverse_One: traverse N's aspect specifications
|
|
|
1462
|
|
|
1463 procedure Traverse_Degenerate_Subprogram (N : Node_Id);
|
|
|
1464 -- Common code to handle null procedures and expression functions. Emit
|
|
|
1465 -- a SCO of the given Kind and N outside of the dominance flow.
|
|
|
1466
|
|
|
1467 -------------------------------
|
|
|
1468 -- Extend_Statement_Sequence --
|
|
|
1469 -------------------------------
|
|
|
1470
|
|
|
1471 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
|
|
|
1472 Dummy : Source_Ptr;
|
|
|
1473 F : Source_Ptr;
|
|
|
1474 T : Source_Ptr;
|
|
|
1475 To_Node : Node_Id := Empty;
|
|
|
1476
|
|
|
1477 begin
|
|
|
1478 Sloc_Range (N, F, T);
|
|
|
1479
|
|
|
1480 case Nkind (N) is
|
|
|
1481 when N_Accept_Statement =>
|
|
|
1482 if Present (Parameter_Specifications (N)) then
|
|
|
1483 To_Node := Last (Parameter_Specifications (N));
|
|
|
1484 elsif Present (Entry_Index (N)) then
|
|
|
1485 To_Node := Entry_Index (N);
|
|
|
1486 else
|
|
|
1487 To_Node := Entry_Direct_Name (N);
|
|
|
1488 end if;
|
|
|
1489
|
|
|
1490 when N_Case_Statement =>
|
|
|
1491 To_Node := Expression (N);
|
|
|
1492
|
|
|
1493 when N_Elsif_Part
|
|
|
1494 | N_If_Statement
|
|
|
1495 =>
|
|
|
1496 To_Node := Condition (N);
|
|
|
1497
|
|
|
1498 when N_Extended_Return_Statement =>
|
|
|
1499 To_Node := Last (Return_Object_Declarations (N));
|
|
|
1500
|
|
|
1501 when N_Loop_Statement =>
|
|
|
1502 To_Node := Iteration_Scheme (N);
|
|
|
1503
|
|
|
1504 when N_Asynchronous_Select
|
|
|
1505 | N_Conditional_Entry_Call
|
|
|
1506 | N_Selective_Accept
|
|
|
1507 | N_Single_Protected_Declaration
|
|
|
1508 | N_Single_Task_Declaration
|
|
|
1509 | N_Timed_Entry_Call
|
|
|
1510 =>
|
|
|
1511 T := F;
|
|
|
1512
|
|
|
1513 when N_Protected_Type_Declaration
|
|
|
1514 | N_Task_Type_Declaration
|
|
|
1515 =>
|
|
|
1516 if Has_Aspects (N) then
|
|
|
1517 To_Node := Last (Aspect_Specifications (N));
|
|
|
1518
|
|
|
1519 elsif Present (Discriminant_Specifications (N)) then
|
|
|
1520 To_Node := Last (Discriminant_Specifications (N));
|
|
|
1521
|
|
|
1522 else
|
|
|
1523 To_Node := Defining_Identifier (N);
|
|
|
1524 end if;
|
|
|
1525
|
|
|
1526 when N_Subexpr =>
|
|
|
1527 To_Node := N;
|
|
|
1528
|
|
|
1529 when others =>
|
|
|
1530 null;
|
|
|
1531 end case;
|
|
|
1532
|
|
|
1533 if Present (To_Node) then
|
|
|
1534 Sloc_Range (To_Node, Dummy, T);
|
|
|
1535 end if;
|
|
|
1536
|
|
|
1537 SC.Append ((N, F, T, Typ));
|
|
|
1538 end Extend_Statement_Sequence;
|
|
|
1539
|
|
|
1540 -----------------------------
|
|
|
1541 -- Process_Decisions_Defer --
|
|
|
1542 -----------------------------
|
|
|
1543
|
|
|
1544 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
|
|
|
1545 begin
|
|
|
1546 SD.Append ((N, No_List, T, Current_Pragma_Sloc));
|
|
|
1547 end Process_Decisions_Defer;
|
|
|
1548
|
|
|
1549 procedure Process_Decisions_Defer (L : List_Id; T : Character) is
|
|
|
1550 begin
|
|
|
1551 SD.Append ((Empty, L, T, Current_Pragma_Sloc));
|
|
|
1552 end Process_Decisions_Defer;
|
|
|
1553
|
|
|
1554 -------------------------
|
|
|
1555 -- Set_Statement_Entry --
|
|
|
1556 -------------------------
|
|
|
1557
|
|
|
1558 procedure Set_Statement_Entry is
|
|
|
1559 SC_Last : constant Int := SC.Last;
|
|
|
1560 SD_Last : constant Int := SD.Last;
|
|
|
1561
|
|
|
1562 begin
|
|
|
1563 -- Output statement entries from saved entries in SC table
|
|
|
1564
|
|
|
1565 for J in SC_First .. SC_Last loop
|
|
|
1566 if J = SC_First then
|
|
|
1567
|
|
|
1568 if Current_Dominant /= No_Dominant then
|
|
|
1569 declare
|
|
|
1570 From : Source_Ptr;
|
|
|
1571 To : Source_Ptr;
|
|
|
1572
|
|
|
1573 begin
|
|
|
1574 Sloc_Range (Current_Dominant.N, From, To);
|
|
|
1575
|
|
|
1576 if Current_Dominant.K /= 'E' then
|
|
|
1577 To := No_Location;
|
|
|
1578 end if;
|
|
|
1579
|
|
|
1580 Set_Raw_Table_Entry
|
|
|
1581 (C1 => '>',
|
|
|
1582 C2 => Current_Dominant.K,
|
|
|
1583 From => From,
|
|
|
1584 To => To,
|
|
|
1585 Last => False,
|
|
|
1586 Pragma_Sloc => No_Location,
|
|
|
1587 Pragma_Aspect_Name => No_Name);
|
|
|
1588 end;
|
|
|
1589 end if;
|
|
|
1590 end if;
|
|
|
1591
|
|
|
1592 declare
|
|
|
1593 SCE : SC_Entry renames SC.Table (J);
|
|
|
1594 Pragma_Sloc : Source_Ptr := No_Location;
|
|
|
1595 Pragma_Aspect_Name : Name_Id := No_Name;
|
|
|
1596
|
|
|
1597 begin
|
|
|
1598 -- For the case of a statement SCO for a pragma controlled by
|
|
|
1599 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
|
|
|
1600 -- those of any nested decision) is emitted only if the pragma
|
|
|
1601 -- is enabled.
|
|
|
1602
|
|
|
1603 if SCE.Typ = 'p' then
|
|
|
1604 Pragma_Sloc := SCE.From;
|
|
|
1605 SCO_Raw_Hash_Table.Set
|
|
|
1606 (Pragma_Sloc, SCO_Raw_Table.Last + 1);
|
|
|
1607 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
|
|
|
1608 pragma Assert (Pragma_Aspect_Name /= No_Name);
|
|
|
1609
|
|
|
1610 elsif SCE.Typ = 'P' then
|
|
|
1611 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
|
|
|
1612 pragma Assert (Pragma_Aspect_Name /= No_Name);
|
|
|
1613 end if;
|
|
|
1614
|
|
|
1615 Set_Raw_Table_Entry
|
|
|
1616 (C1 => 'S',
|
|
|
1617 C2 => SCE.Typ,
|
|
|
1618 From => SCE.From,
|
|
|
1619 To => SCE.To,
|
|
|
1620 Last => (J = SC_Last),
|
|
|
1621 Pragma_Sloc => Pragma_Sloc,
|
|
|
1622 Pragma_Aspect_Name => Pragma_Aspect_Name);
|
|
|
1623 end;
|
|
|
1624 end loop;
|
|
|
1625
|
|
|
1626 -- Last statement of basic block, if present, becomes new current
|
|
|
1627 -- dominant.
|
|
|
1628
|
|
|
1629 if SC_Last >= SC_First then
|
|
|
1630 Current_Dominant := ('S', SC.Table (SC_Last).N);
|
|
|
1631 end if;
|
|
|
1632
|
|
|
1633 -- Clear out used section of SC table
|
|
|
1634
|
|
|
1635 SC.Set_Last (SC_First - 1);
|
|
|
1636
|
|
|
1637 -- Output any embedded decisions
|
|
|
1638
|
|
|
1639 for J in SD_First .. SD_Last loop
|
|
|
1640 declare
|
|
|
1641 SDE : SD_Entry renames SD.Table (J);
|
|
|
1642
|
|
|
1643 begin
|
|
|
1644 if Present (SDE.Nod) then
|
|
|
1645 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
|
|
|
1646 else
|
|
|
1647 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
|
|
|
1648 end if;
|
|
|
1649 end;
|
|
|
1650 end loop;
|
|
|
1651
|
|
|
1652 -- Clear out used section of SD table
|
|
|
1653
|
|
|
1654 SD.Set_Last (SD_First - 1);
|
|
|
1655 end Set_Statement_Entry;
|
|
|
1656
|
|
|
1657 ----------------------
|
|
|
1658 -- Traverse_Aspects --
|
|
|
1659 ----------------------
|
|
|
1660
|
|
|
1661 procedure Traverse_Aspects (N : Node_Id) is
|
|
|
1662 AE : Node_Id;
|
|
|
1663 AN : Node_Id;
|
|
|
1664 C1 : Character;
|
|
|
1665
|
|
|
1666 begin
|
|
|
1667 AN := First (Aspect_Specifications (N));
|
|
|
1668 while Present (AN) loop
|
|
|
1669 AE := Expression (AN);
|
|
|
1670
|
|
|
1671 -- SCOs are generated before semantic analysis/expansion:
|
|
|
1672 -- PPCs are not split yet.
|
|
|
1673
|
|
|
1674 pragma Assert (not Split_PPC (AN));
|
|
|
1675
|
|
|
1676 C1 := ASCII.NUL;
|
|
|
1677
|
|
|
1678 case Get_Aspect_Id (AN) is
|
|
|
1679
|
|
|
1680 -- Aspects rewritten into pragmas controlled by a Check_Policy:
|
|
|
1681 -- Current_Pragma_Sloc must be set to the sloc of the aspect
|
|
|
1682 -- specification. The corresponding pragma will have the same
|
|
|
1683 -- sloc. Note that Invariant, Pre, and Post will be enabled if
|
|
|
1684 -- the policy is Check; on the other hand, predicate aspects
|
|
|
1685 -- will be enabled for Check and Ignore (when Add_Predicate
|
|
|
1686 -- is called) because the actual checks occur in client units.
|
|
|
1687 -- When the assertion policy for Predicate is Disable, the
|
|
|
1688 -- SCO remains disabled, because Add_Predicate is never called.
|
|
|
1689
|
|
|
1690 -- Pre/post can have checks in client units too because of
|
|
|
1691 -- inheritance, so should they receive the same treatment???
|
|
|
1692
|
|
|
1693 when Aspect_Dynamic_Predicate
|
|
|
1694 | Aspect_Invariant
|
|
|
1695 | Aspect_Post
|
|
|
1696 | Aspect_Postcondition
|
|
|
1697 | Aspect_Pre
|
|
|
1698 | Aspect_Precondition
|
|
|
1699 | Aspect_Predicate
|
|
|
1700 | Aspect_Static_Predicate
|
|
|
1701 | Aspect_Type_Invariant
|
|
|
1702 =>
|
|
|
1703 C1 := 'a';
|
|
|
1704
|
|
|
1705 -- Other aspects: just process any decision nested in the
|
|
|
1706 -- aspect expression.
|
|
|
1707
|
|
|
1708 when others =>
|
|
|
1709 if Has_Decision (AE) then
|
|
|
1710 C1 := 'X';
|
|
|
1711 end if;
|
|
|
1712 end case;
|
|
|
1713
|
|
|
1714 if C1 /= ASCII.NUL then
|
|
|
1715 pragma Assert (Current_Pragma_Sloc = No_Location);
|
|
|
1716
|
|
|
1717 if C1 = 'a' or else C1 = 'A' then
|
|
|
1718 Current_Pragma_Sloc := Sloc (AN);
|
|
|
1719 end if;
|
|
|
1720
|
|
|
1721 Process_Decisions_Defer (AE, C1);
|
|
|
1722
|
|
|
1723 Current_Pragma_Sloc := No_Location;
|
|
|
1724 end if;
|
|
|
1725
|
|
|
1726 Next (AN);
|
|
|
1727 end loop;
|
|
|
1728 end Traverse_Aspects;
|
|
|
1729
|
|
|
1730 ------------------------------------
|
|
|
1731 -- Traverse_Degenerate_Subprogram --
|
|
|
1732 ------------------------------------
|
|
|
1733
|
|
|
1734 procedure Traverse_Degenerate_Subprogram (N : Node_Id) is
|
|
|
1735 begin
|
|
|
1736 -- Complete current sequence of statements
|
|
|
1737
|
|
|
1738 Set_Statement_Entry;
|
|
|
1739
|
|
|
1740 declare
|
|
|
1741 Saved_Dominant : constant Dominant_Info := Current_Dominant;
|
|
|
1742 -- Save last statement in current sequence as dominant
|
|
|
1743
|
|
|
1744 begin
|
|
|
1745 -- Output statement SCO for degenerate subprogram body (null
|
|
|
1746 -- statement or freestanding expression) outside of the dominance
|
|
|
1747 -- chain.
|
|
|
1748
|
|
|
1749 Current_Dominant := No_Dominant;
|
|
|
1750 Extend_Statement_Sequence (N, Typ => ' ');
|
|
|
1751
|
|
|
1752 -- For the case of an expression-function, collect decisions
|
|
|
1753 -- embedded in the expression now.
|
|
|
1754
|
|
|
1755 if Nkind (N) in N_Subexpr then
|
|
|
1756 Process_Decisions_Defer (N, 'X');
|
|
|
1757 end if;
|
|
|
1758
|
|
|
1759 Set_Statement_Entry;
|
|
|
1760
|
|
|
1761 -- Restore current dominant information designating last statement
|
|
|
1762 -- in previous sequence (i.e. make the dominance chain skip over
|
|
|
1763 -- the degenerate body).
|
|
|
1764
|
|
|
1765 Current_Dominant := Saved_Dominant;
|
|
|
1766 end;
|
|
|
1767 end Traverse_Degenerate_Subprogram;
|
|
|
1768
|
|
|
1769 ------------------
|
|
|
1770 -- Traverse_One --
|
|
|
1771 ------------------
|
|
|
1772
|
|
|
1773 procedure Traverse_One (N : Node_Id) is
|
|
|
1774 begin
|
|
|
1775 -- Initialize or extend current statement sequence. Note that for
|
|
|
1776 -- special cases such as IF and Case statements we will modify
|
|
|
1777 -- the range to exclude internal statements that should not be
|
|
|
1778 -- counted as part of the current statement sequence.
|
|
|
1779
|
|
|
1780 case Nkind (N) is
|
|
|
1781
|
|
|
1782 -- Package declaration
|
|
|
1783
|
|
|
1784 when N_Package_Declaration =>
|
|
|
1785 Set_Statement_Entry;
|
|
|
1786 Traverse_Package_Declaration (N, Current_Dominant);
|
|
|
1787
|
|
|
1788 -- Generic package declaration
|
|
|
1789
|
|
|
1790 when N_Generic_Package_Declaration =>
|
|
|
1791 Set_Statement_Entry;
|
|
|
1792 Traverse_Generic_Package_Declaration (N);
|
|
|
1793
|
|
|
1794 -- Package body
|
|
|
1795
|
|
|
1796 when N_Package_Body =>
|
|
|
1797 Set_Statement_Entry;
|
|
|
1798 Traverse_Package_Body (N);
|
|
|
1799
|
|
|
1800 -- Subprogram declaration or subprogram body stub
|
|
|
1801
|
|
|
1802 when N_Expression_Function
|
|
|
1803 | N_Subprogram_Body_Stub
|
|
|
1804 | N_Subprogram_Declaration
|
|
|
1805 =>
|
|
|
1806 declare
|
|
|
1807 Spec : constant Node_Id := Specification (N);
|
|
|
1808 begin
|
|
|
1809 Process_Decisions_Defer
|
|
|
1810 (Parameter_Specifications (Spec), 'X');
|
|
|
1811
|
|
|
1812 -- Case of a null procedure: generate SCO for fictitious
|
|
|
1813 -- NULL statement located at the NULL keyword in the
|
|
|
1814 -- procedure specification.
|
|
|
1815
|
|
|
1816 if Nkind (N) = N_Subprogram_Declaration
|
|
|
1817 and then Nkind (Spec) = N_Procedure_Specification
|
|
|
1818 and then Null_Present (Spec)
|
|
|
1819 then
|
|
|
1820 Traverse_Degenerate_Subprogram (Null_Statement (Spec));
|
|
|
1821
|
|
|
1822 -- Case of an expression function: generate a statement SCO
|
|
|
1823 -- for the expression (and then decision SCOs for any nested
|
|
|
1824 -- decisions).
|
|
|
1825
|
|
|
1826 elsif Nkind (N) = N_Expression_Function then
|
|
|
1827 Traverse_Degenerate_Subprogram (Expression (N));
|
|
|
1828 end if;
|
|
|
1829 end;
|
|
|
1830
|
|
|
1831 -- Entry declaration
|
|
|
1832
|
|
|
1833 when N_Entry_Declaration =>
|
|
|
1834 Process_Decisions_Defer (Parameter_Specifications (N), 'X');
|
|
|
1835
|
|
|
1836 -- Generic subprogram declaration
|
|
|
1837
|
|
|
1838 when N_Generic_Subprogram_Declaration =>
|
|
|
1839 Process_Decisions_Defer
|
|
|
1840 (Generic_Formal_Declarations (N), 'X');
|
|
|
1841 Process_Decisions_Defer
|
|
|
1842 (Parameter_Specifications (Specification (N)), 'X');
|
|
|
1843
|
|
|
1844 -- Task or subprogram body
|
|
|
1845
|
|
|
1846 when N_Subprogram_Body
|
|
|
1847 | N_Task_Body
|
|
|
1848 =>
|
|
|
1849 Set_Statement_Entry;
|
|
|
1850 Traverse_Subprogram_Or_Task_Body (N);
|
|
|
1851
|
|
|
1852 -- Entry body
|
|
|
1853
|
|
|
1854 when N_Entry_Body =>
|
|
|
1855 declare
|
|
|
1856 Cond : constant Node_Id :=
|
|
|
1857 Condition (Entry_Body_Formal_Part (N));
|
|
|
1858
|
|
|
1859 Inner_Dominant : Dominant_Info := No_Dominant;
|
|
|
1860
|
|
|
1861 begin
|
|
|
1862 Set_Statement_Entry;
|
|
|
1863
|
|
|
1864 if Present (Cond) then
|
|
|
1865 Process_Decisions_Defer (Cond, 'G');
|
|
|
1866
|
|
|
1867 -- For an entry body with a barrier, the entry body
|
|
|
1868 -- is dominanted by a True evaluation of the barrier.
|
|
|
1869
|
|
|
1870 Inner_Dominant := ('T', N);
|
|
|
1871 end if;
|
|
|
1872
|
|
|
1873 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
|
|
|
1874 end;
|
|
|
1875
|
|
|
1876 -- Protected body
|
|
|
1877
|
|
|
1878 when N_Protected_Body =>
|
|
|
1879 Set_Statement_Entry;
|
|
|
1880 Traverse_Declarations_Or_Statements (Declarations (N));
|
|
|
1881
|
|
|
1882 -- Exit statement, which is an exit statement in the SCO sense,
|
|
|
1883 -- so it is included in the current statement sequence, but
|
|
|
1884 -- then it terminates this sequence. We also have to process
|
|
|
1885 -- any decisions in the exit statement expression.
|
|
|
1886
|
|
|
1887 when N_Exit_Statement =>
|
|
|
1888 Extend_Statement_Sequence (N, 'E');
|
|
|
1889 Process_Decisions_Defer (Condition (N), 'E');
|
|
|
1890 Set_Statement_Entry;
|
|
|
1891
|
|
|
1892 -- If condition is present, then following statement is
|
|
|
1893 -- only executed if the condition evaluates to False.
|
|
|
1894
|
|
|
1895 if Present (Condition (N)) then
|
|
|
1896 Current_Dominant := ('F', N);
|
|
|
1897 else
|
|
|
1898 Current_Dominant := No_Dominant;
|
|
|
1899 end if;
|
|
|
1900
|
|
|
1901 -- Label, which breaks the current statement sequence, but the
|
|
|
1902 -- label itself is not included in the next statement sequence,
|
|
|
1903 -- since it generates no code.
|
|
|
1904
|
|
|
1905 when N_Label =>
|
|
|
1906 Set_Statement_Entry;
|
|
|
1907 Current_Dominant := No_Dominant;
|
|
|
1908
|
|
|
1909 -- Block statement, which breaks the current statement sequence
|
|
|
1910
|
|
|
1911 when N_Block_Statement =>
|
|
|
1912 Set_Statement_Entry;
|
|
|
1913
|
|
|
1914 -- The first statement in the handled sequence of statements
|
|
|
1915 -- is dominated by the elaboration of the last declaration.
|
|
|
1916
|
|
|
1917 Current_Dominant := Traverse_Declarations_Or_Statements
|
|
|
1918 (L => Declarations (N),
|
|
|
1919 D => Current_Dominant);
|
|
|
1920
|
|
|
1921 Traverse_Handled_Statement_Sequence
|
|
|
1922 (N => Handled_Statement_Sequence (N),
|
|
|
1923 D => Current_Dominant);
|
|
|
1924
|
|
|
1925 -- If statement, which breaks the current statement sequence,
|
|
|
1926 -- but we include the condition in the current sequence.
|
|
|
1927
|
|
|
1928 when N_If_Statement =>
|
|
|
1929 Current_Test := N;
|
|
|
1930 Extend_Statement_Sequence (N, 'I');
|
|
|
1931 Process_Decisions_Defer (Condition (N), 'I');
|
|
|
1932 Set_Statement_Entry;
|
|
|
1933
|
|
|
1934 -- Now we traverse the statements in the THEN part
|
|
|
1935
|
|
|
1936 Traverse_Declarations_Or_Statements
|
|
|
1937 (L => Then_Statements (N),
|
|
|
1938 D => ('T', N));
|
|
|
1939
|
|
|
1940 -- Loop through ELSIF parts if present
|
|
|
1941
|
|
|
1942 if Present (Elsif_Parts (N)) then
|
|
|
1943 declare
|
|
|
1944 Saved_Dominant : constant Dominant_Info :=
|
|
|
1945 Current_Dominant;
|
|
|
1946
|
|
|
1947 Elif : Node_Id := First (Elsif_Parts (N));
|
|
|
1948
|
|
|
1949 begin
|
|
|
1950 while Present (Elif) loop
|
|
|
1951
|
|
|
1952 -- An Elsif is executed only if the previous test
|
|
|
1953 -- got a FALSE outcome.
|
|
|
1954
|
|
|
1955 Current_Dominant := ('F', Current_Test);
|
|
|
1956
|
|
|
1957 -- Now update current test information
|
|
|
1958
|
|
|
1959 Current_Test := Elif;
|
|
|
1960
|
|
|
1961 -- We generate a statement sequence for the
|
|
|
1962 -- construct "ELSIF condition", so that we have
|
|
|
1963 -- a statement for the resulting decisions.
|
|
|
1964
|
|
|
1965 Extend_Statement_Sequence (Elif, 'I');
|
|
|
1966 Process_Decisions_Defer (Condition (Elif), 'I');
|
|
|
1967 Set_Statement_Entry;
|
|
|
1968
|
|
|
1969 -- An ELSIF part is never guaranteed to have
|
|
|
1970 -- been executed, following statements are only
|
|
|
1971 -- dominated by the initial IF statement.
|
|
|
1972
|
|
|
1973 Current_Dominant := Saved_Dominant;
|
|
|
1974
|
|
|
1975 -- Traverse the statements in the ELSIF
|
|
|
1976
|
|
|
1977 Traverse_Declarations_Or_Statements
|
|
|
1978 (L => Then_Statements (Elif),
|
|
|
1979 D => ('T', Elif));
|
|
|
1980 Next (Elif);
|
|
|
1981 end loop;
|
|
|
1982 end;
|
|
|
1983 end if;
|
|
|
1984
|
|
|
1985 -- Finally traverse the ELSE statements if present
|
|
|
1986
|
|
|
1987 Traverse_Declarations_Or_Statements
|
|
|
1988 (L => Else_Statements (N),
|
|
|
1989 D => ('F', Current_Test));
|
|
|
1990
|
|
|
1991 -- CASE statement, which breaks the current statement sequence,
|
|
|
1992 -- but we include the expression in the current sequence.
|
|
|
1993
|
|
|
1994 when N_Case_Statement =>
|
|
|
1995 Extend_Statement_Sequence (N, 'C');
|
|
|
1996 Process_Decisions_Defer (Expression (N), 'X');
|
|
|
1997 Set_Statement_Entry;
|
|
|
1998
|
|
|
1999 -- Process case branches, all of which are dominated by the
|
|
|
2000 -- CASE statement.
|
|
|
2001
|
|
|
2002 declare
|
|
|
2003 Alt : Node_Id;
|
|
|
2004 begin
|
|
|
2005 Alt := First_Non_Pragma (Alternatives (N));
|
|
|
2006 while Present (Alt) loop
|
|
|
2007 Traverse_Declarations_Or_Statements
|
|
|
2008 (L => Statements (Alt),
|
|
|
2009 D => Current_Dominant);
|
|
|
2010 Next (Alt);
|
|
|
2011 end loop;
|
|
|
2012 end;
|
|
|
2013
|
|
|
2014 -- ACCEPT statement
|
|
|
2015
|
|
|
2016 when N_Accept_Statement =>
|
|
|
2017 Extend_Statement_Sequence (N, 'A');
|
|
|
2018 Set_Statement_Entry;
|
|
|
2019
|
|
|
2020 -- Process sequence of statements, dominant is the ACCEPT
|
|
|
2021 -- statement.
|
|
|
2022
|
|
|
2023 Traverse_Handled_Statement_Sequence
|
|
|
2024 (N => Handled_Statement_Sequence (N),
|
|
|
2025 D => Current_Dominant);
|
|
|
2026
|
|
|
2027 -- SELECT
|
|
|
2028
|
|
|
2029 when N_Selective_Accept =>
|
|
|
2030 Extend_Statement_Sequence (N, 'S');
|
|
|
2031 Set_Statement_Entry;
|
|
|
2032
|
|
|
2033 -- Process alternatives
|
|
|
2034
|
|
|
2035 declare
|
|
|
2036 Alt : Node_Id;
|
|
|
2037 Guard : Node_Id;
|
|
|
2038 S_Dom : Dominant_Info;
|
|
|
2039
|
|
|
2040 begin
|
|
|
2041 Alt := First (Select_Alternatives (N));
|
|
|
2042 while Present (Alt) loop
|
|
|
2043 S_Dom := Current_Dominant;
|
|
|
2044 Guard := Condition (Alt);
|
|
|
2045
|
|
|
2046 if Present (Guard) then
|
|
|
2047 Process_Decisions
|
|
|
2048 (Guard,
|
|
|
2049 'G',
|
|
|
2050 Pragma_Sloc => No_Location);
|
|
|
2051 Current_Dominant := ('T', Guard);
|
|
|
2052 end if;
|
|
|
2053
|
|
|
2054 Traverse_One (Alt);
|
|
|
2055
|
|
|
2056 Current_Dominant := S_Dom;
|
|
|
2057 Next (Alt);
|
|
|
2058 end loop;
|
|
|
2059 end;
|
|
|
2060
|
|
|
2061 Traverse_Declarations_Or_Statements
|
|
|
2062 (L => Else_Statements (N),
|
|
|
2063 D => Current_Dominant);
|
|
|
2064
|
|
|
2065 when N_Conditional_Entry_Call
|
|
|
2066 | N_Timed_Entry_Call
|
|
|
2067 =>
|
|
|
2068 Extend_Statement_Sequence (N, 'S');
|
|
|
2069 Set_Statement_Entry;
|
|
|
2070
|
|
|
2071 -- Process alternatives
|
|
|
2072
|
|
|
2073 Traverse_One (Entry_Call_Alternative (N));
|
|
|
2074
|
|
|
2075 if Nkind (N) = N_Timed_Entry_Call then
|
|
|
2076 Traverse_One (Delay_Alternative (N));
|
|
|
2077 else
|
|
|
2078 Traverse_Declarations_Or_Statements
|
|
|
2079 (L => Else_Statements (N),
|
|
|
2080 D => Current_Dominant);
|
|
|
2081 end if;
|
|
|
2082
|
|
|
2083 when N_Asynchronous_Select =>
|
|
|
2084 Extend_Statement_Sequence (N, 'S');
|
|
|
2085 Set_Statement_Entry;
|
|
|
2086
|
|
|
2087 Traverse_One (Triggering_Alternative (N));
|
|
|
2088 Traverse_Declarations_Or_Statements
|
|
|
2089 (L => Statements (Abortable_Part (N)),
|
|
|
2090 D => Current_Dominant);
|
|
|
2091
|
|
|
2092 when N_Accept_Alternative =>
|
|
|
2093 Traverse_Declarations_Or_Statements
|
|
|
2094 (L => Statements (N),
|
|
|
2095 D => Current_Dominant,
|
|
|
2096 P => Accept_Statement (N));
|
|
|
2097
|
|
|
2098 when N_Entry_Call_Alternative =>
|
|
|
2099 Traverse_Declarations_Or_Statements
|
|
|
2100 (L => Statements (N),
|
|
|
2101 D => Current_Dominant,
|
|
|
2102 P => Entry_Call_Statement (N));
|
|
|
2103
|
|
|
2104 when N_Delay_Alternative =>
|
|
|
2105 Traverse_Declarations_Or_Statements
|
|
|
2106 (L => Statements (N),
|
|
|
2107 D => Current_Dominant,
|
|
|
2108 P => Delay_Statement (N));
|
|
|
2109
|
|
|
2110 when N_Triggering_Alternative =>
|
|
|
2111 Traverse_Declarations_Or_Statements
|
|
|
2112 (L => Statements (N),
|
|
|
2113 D => Current_Dominant,
|
|
|
2114 P => Triggering_Statement (N));
|
|
|
2115
|
|
|
2116 when N_Terminate_Alternative =>
|
|
|
2117
|
|
|
2118 -- It is dubious to emit a statement SCO for a TERMINATE
|
|
|
2119 -- alternative, since no code is actually executed if the
|
|
|
2120 -- alternative is selected -- the tasking runtime call just
|
|
|
2121 -- never returns???
|
|
|
2122
|
|
|
2123 Extend_Statement_Sequence (N, ' ');
|
|
|
2124 Set_Statement_Entry;
|
|
|
2125
|
|
|
2126 -- Unconditional exit points, which are included in the current
|
|
|
2127 -- statement sequence, but then terminate it
|
|
|
2128
|
|
|
2129 when N_Goto_Statement
|
|
|
2130 | N_Raise_Statement
|
|
|
2131 | N_Requeue_Statement
|
|
|
2132 =>
|
|
|
2133 Extend_Statement_Sequence (N, ' ');
|
|
|
2134 Set_Statement_Entry;
|
|
|
2135 Current_Dominant := No_Dominant;
|
|
|
2136
|
|
|
2137 -- Simple return statement. which is an exit point, but we
|
|
|
2138 -- have to process the return expression for decisions.
|
|
|
2139
|
|
|
2140 when N_Simple_Return_Statement =>
|
|
|
2141 Extend_Statement_Sequence (N, ' ');
|
|
|
2142 Process_Decisions_Defer (Expression (N), 'X');
|
|
|
2143 Set_Statement_Entry;
|
|
|
2144 Current_Dominant := No_Dominant;
|
|
|
2145
|
|
|
2146 -- Extended return statement
|
|
|
2147
|
|
|
2148 when N_Extended_Return_Statement =>
|
|
|
2149 Extend_Statement_Sequence (N, 'R');
|
|
|
2150 Process_Decisions_Defer (Return_Object_Declarations (N), 'X');
|
|
|
2151 Set_Statement_Entry;
|
|
|
2152
|
|
|
2153 Traverse_Handled_Statement_Sequence
|
|
|
2154 (N => Handled_Statement_Sequence (N),
|
|
|
2155 D => Current_Dominant);
|
|
|
2156
|
|
|
2157 Current_Dominant := No_Dominant;
|
|
|
2158
|
|
|
2159 -- Loop ends the current statement sequence, but we include
|
|
|
2160 -- the iteration scheme if present in the current sequence.
|
|
|
2161 -- But the body of the loop starts a new sequence, since it
|
|
|
2162 -- may not be executed as part of the current sequence.
|
|
|
2163
|
|
|
2164 when N_Loop_Statement =>
|
|
|
2165 declare
|
|
|
2166 ISC : constant Node_Id := Iteration_Scheme (N);
|
|
|
2167 Inner_Dominant : Dominant_Info := No_Dominant;
|
|
|
2168
|
|
|
2169 begin
|
|
|
2170 if Present (ISC) then
|
|
|
2171
|
|
|
2172 -- If iteration scheme present, extend the current
|
|
|
2173 -- statement sequence to include the iteration scheme
|
|
|
2174 -- and process any decisions it contains.
|
|
|
2175
|
|
|
2176 -- While loop
|
|
|
2177
|
|
|
2178 if Present (Condition (ISC)) then
|
|
|
2179 Extend_Statement_Sequence (N, 'W');
|
|
|
2180 Process_Decisions_Defer (Condition (ISC), 'W');
|
|
|
2181
|
|
|
2182 -- Set more specific dominant for inner statements
|
|
|
2183 -- (the control sloc for the decision is that of
|
|
|
2184 -- the WHILE token).
|
|
|
2185
|
|
|
2186 Inner_Dominant := ('T', ISC);
|
|
|
2187
|
|
|
2188 -- For loop
|
|
|
2189
|
|
|
2190 else
|
|
|
2191 Extend_Statement_Sequence (N, 'F');
|
|
|
2192 Process_Decisions_Defer
|
|
|
2193 (Loop_Parameter_Specification (ISC), 'X');
|
|
|
2194 end if;
|
|
|
2195 end if;
|
|
|
2196
|
|
|
2197 Set_Statement_Entry;
|
|
|
2198
|
|
|
2199 if Inner_Dominant = No_Dominant then
|
|
|
2200 Inner_Dominant := Current_Dominant;
|
|
|
2201 end if;
|
|
|
2202
|
|
|
2203 Traverse_Declarations_Or_Statements
|
|
|
2204 (L => Statements (N),
|
|
|
2205 D => Inner_Dominant);
|
|
|
2206 end;
|
|
|
2207
|
|
|
2208 -- Pragma
|
|
|
2209
|
|
|
2210 when N_Pragma =>
|
|
|
2211
|
|
|
2212 -- Record sloc of pragma (pragmas don't nest)
|
|
|
2213
|
|
|
2214 pragma Assert (Current_Pragma_Sloc = No_Location);
|
|
|
2215 Current_Pragma_Sloc := Sloc (N);
|
|
|
2216
|
|
|
2217 -- Processing depends on the kind of pragma
|
|
|
2218
|
|
|
2219 declare
|
|
|
2220 Nam : constant Name_Id := Pragma_Name_Unmapped (N);
|
|
|
2221 Arg : Node_Id :=
|
|
|
2222 First (Pragma_Argument_Associations (N));
|
|
|
2223 Typ : Character;
|
|
|
2224
|
|
|
2225 begin
|
|
|
2226 case Nam is
|
|
|
2227 when Name_Assert
|
|
|
2228 | Name_Assert_And_Cut
|
|
|
2229 | Name_Assume
|
|
|
2230 | Name_Check
|
|
|
2231 | Name_Loop_Invariant
|
|
|
2232 | Name_Postcondition
|
|
|
2233 | Name_Precondition
|
|
|
2234 =>
|
|
|
2235 -- For Assert/Check/Precondition/Postcondition, we
|
|
|
2236 -- must generate a P entry for the decision. Note
|
|
|
2237 -- that this is done unconditionally at this stage.
|
|
|
2238 -- Output for disabled pragmas is suppressed later
|
|
|
2239 -- on when we output the decision line in Put_SCOs,
|
|
|
2240 -- depending on setting by Set_SCO_Pragma_Enabled.
|
|
|
2241
|
|
|
2242 if Nam = Name_Check then
|
|
|
2243 Next (Arg);
|
|
|
2244 end if;
|
|
|
2245
|
|
|
2246 Process_Decisions_Defer (Expression (Arg), 'P');
|
|
|
2247 Typ := 'p';
|
|
|
2248
|
|
|
2249 -- Pre/postconditions can be inherited so SCO should
|
|
|
2250 -- never be deactivated???
|
|
|
2251
|
|
|
2252 when Name_Debug =>
|
|
|
2253 if Present (Arg) and then Present (Next (Arg)) then
|
|
|
2254
|
|
|
2255 -- Case of a dyadic pragma Debug: first argument
|
|
|
2256 -- is a P decision, any nested decision in the
|
|
|
2257 -- second argument is an X decision.
|
|
|
2258
|
|
|
2259 Process_Decisions_Defer (Expression (Arg), 'P');
|
|
|
2260 Next (Arg);
|
|
|
2261 end if;
|
|
|
2262
|
|
|
2263 Process_Decisions_Defer (Expression (Arg), 'X');
|
|
|
2264 Typ := 'p';
|
|
|
2265
|
|
|
2266 -- For all other pragmas, we generate decision entries
|
|
|
2267 -- for any embedded expressions, and the pragma is
|
|
|
2268 -- never disabled.
|
|
|
2269
|
|
|
2270 -- Should generate P decisions (not X) for assertion
|
|
|
2271 -- related pragmas: [Type_]Invariant,
|
|
|
2272 -- [{Static,Dynamic}_]Predicate???
|
|
|
2273
|
|
|
2274 when others =>
|
|
|
2275 Process_Decisions_Defer (N, 'X');
|
|
|
2276 Typ := 'P';
|
|
|
2277 end case;
|
|
|
2278
|
|
|
2279 -- Add statement SCO
|
|
|
2280
|
|
|
2281 Extend_Statement_Sequence (N, Typ);
|
|
|
2282
|
|
|
2283 Current_Pragma_Sloc := No_Location;
|
|
|
2284 end;
|
|
|
2285
|
|
|
2286 -- Object declaration. Ignored if Prev_Ids is set, since the
|
|
|
2287 -- parser generates multiple instances of the whole declaration
|
|
|
2288 -- if there is more than one identifier declared, and we only
|
|
|
2289 -- want one entry in the SCOs, so we take the first, for which
|
|
|
2290 -- Prev_Ids is False.
|
|
|
2291
|
|
|
2292 when N_Number_Declaration
|
|
|
2293 | N_Object_Declaration
|
|
|
2294 =>
|
|
|
2295 if not Prev_Ids (N) then
|
|
|
2296 Extend_Statement_Sequence (N, 'o');
|
|
|
2297
|
|
|
2298 if Has_Decision (N) then
|
|
|
2299 Process_Decisions_Defer (N, 'X');
|
|
|
2300 end if;
|
|
|
2301 end if;
|
|
|
2302
|
|
|
2303 -- All other cases, which extend the current statement sequence
|
|
|
2304 -- but do not terminate it, even if they have nested decisions.
|
|
|
2305
|
|
|
2306 when N_Protected_Type_Declaration
|
|
|
2307 | N_Task_Type_Declaration
|
|
|
2308 =>
|
|
|
2309 Extend_Statement_Sequence (N, 't');
|
|
|
2310 Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
|
|
|
2311 Set_Statement_Entry;
|
|
|
2312
|
|
|
2313 Traverse_Sync_Definition (N);
|
|
|
2314
|
|
|
2315 when N_Single_Protected_Declaration
|
|
|
2316 | N_Single_Task_Declaration
|
|
|
2317 =>
|
|
|
2318 Extend_Statement_Sequence (N, 'o');
|
|
|
2319 Set_Statement_Entry;
|
|
|
2320
|
|
|
2321 Traverse_Sync_Definition (N);
|
|
|
2322
|
|
|
2323 when others =>
|
|
|
2324
|
|
|
2325 -- Determine required type character code, or ASCII.NUL if
|
|
|
2326 -- no SCO should be generated for this node.
|
|
|
2327
|
|
|
2328 declare
|
|
|
2329 NK : constant Node_Kind := Nkind (N);
|
|
|
2330 Typ : Character;
|
|
|
2331
|
|
|
2332 begin
|
|
|
2333 case NK is
|
|
|
2334 when N_Full_Type_Declaration
|
|
|
2335 | N_Incomplete_Type_Declaration
|
|
|
2336 | N_Private_Extension_Declaration
|
|
|
2337 | N_Private_Type_Declaration
|
|
|
2338 =>
|
|
|
2339 Typ := 't';
|
|
|
2340
|
|
|
2341 when N_Subtype_Declaration =>
|
|
|
2342 Typ := 's';
|
|
|
2343
|
|
|
2344 when N_Renaming_Declaration =>
|
|
|
2345 Typ := 'r';
|
|
|
2346
|
|
|
2347 when N_Generic_Instantiation =>
|
|
|
2348 Typ := 'i';
|
|
|
2349
|
|
|
2350 when N_Package_Body_Stub
|
|
|
2351 | N_Protected_Body_Stub
|
|
|
2352 | N_Representation_Clause
|
|
|
2353 | N_Task_Body_Stub
|
|
|
2354 | N_Use_Package_Clause
|
|
|
2355 | N_Use_Type_Clause
|
|
|
2356 =>
|
|
|
2357 Typ := ASCII.NUL;
|
|
|
2358
|
|
|
2359 when N_Procedure_Call_Statement =>
|
|
|
2360 Typ := ' ';
|
|
|
2361
|
|
|
2362 when others =>
|
|
|
2363 if NK in N_Statement_Other_Than_Procedure_Call then
|
|
|
2364 Typ := ' ';
|
|
|
2365 else
|
|
|
2366 Typ := 'd';
|
|
|
2367 end if;
|
|
|
2368 end case;
|
|
|
2369
|
|
|
2370 if Typ /= ASCII.NUL then
|
|
|
2371 Extend_Statement_Sequence (N, Typ);
|
|
|
2372 end if;
|
|
|
2373 end;
|
|
|
2374
|
|
|
2375 -- Process any embedded decisions
|
|
|
2376
|
|
|
2377 if Has_Decision (N) then
|
|
|
2378 Process_Decisions_Defer (N, 'X');
|
|
|
2379 end if;
|
|
|
2380 end case;
|
|
|
2381
|
|
|
2382 -- Process aspects if present
|
|
|
2383
|
|
|
2384 Traverse_Aspects (N);
|
|
|
2385 end Traverse_One;
|
|
|
2386
|
|
|
2387 -- Start of processing for Traverse_Declarations_Or_Statements
|
|
|
2388
|
|
|
2389 begin
|
|
|
2390 -- Process single prefixed node
|
|
|
2391
|
|
|
2392 if Present (P) then
|
|
|
2393 Traverse_One (P);
|
|
|
2394 end if;
|
|
|
2395
|
|
|
2396 -- Loop through statements or declarations
|
|
|
2397
|
|
|
2398 if Is_Non_Empty_List (L) then
|
|
|
2399 N := First (L);
|
|
|
2400 while Present (N) loop
|
|
|
2401
|
|
|
2402 -- Note: For separate bodies, we see the tree after Par.Labl has
|
|
|
2403 -- introduced implicit labels, so we need to ignore those nodes.
|
|
|
2404
|
|
|
2405 if Nkind (N) /= N_Implicit_Label_Declaration then
|
|
|
2406 Traverse_One (N);
|
|
|
2407 end if;
|
|
|
2408
|
|
|
2409 Next (N);
|
|
|
2410 end loop;
|
|
|
2411
|
|
|
2412 end if;
|
|
|
2413
|
|
|
2414 -- End sequence of statements and flush deferred decisions
|
|
|
2415
|
|
|
2416 if Present (P) or else Is_Non_Empty_List (L) then
|
|
|
2417 Set_Statement_Entry;
|
|
|
2418 end if;
|
|
|
2419
|
|
|
2420 return Current_Dominant;
|
|
|
2421 end Traverse_Declarations_Or_Statements;
|
|
|
2422
|
|
|
2423 ------------------------------------------
|
|
|
2424 -- Traverse_Generic_Package_Declaration --
|
|
|
2425 ------------------------------------------
|
|
|
2426
|
|
|
2427 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
|
|
|
2428 begin
|
|
|
2429 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
|
|
|
2430 Traverse_Package_Declaration (N);
|
|
|
2431 end Traverse_Generic_Package_Declaration;
|
|
|
2432
|
|
|
2433 -----------------------------------------
|
|
|
2434 -- Traverse_Handled_Statement_Sequence --
|
|
|
2435 -----------------------------------------
|
|
|
2436
|
|
|
2437 procedure Traverse_Handled_Statement_Sequence
|
|
|
2438 (N : Node_Id;
|
|
|
2439 D : Dominant_Info := No_Dominant)
|
|
|
2440 is
|
|
|
2441 Handler : Node_Id;
|
|
|
2442
|
|
|
2443 begin
|
|
|
2444 -- For package bodies without a statement part, the parser adds an empty
|
|
|
2445 -- one, to normalize the representation. The null statement therein,
|
|
|
2446 -- which does not come from source, does not get a SCO.
|
|
|
2447
|
|
|
2448 if Present (N) and then Comes_From_Source (N) then
|
|
|
2449 Traverse_Declarations_Or_Statements (Statements (N), D);
|
|
|
2450
|
|
|
2451 if Present (Exception_Handlers (N)) then
|
|
|
2452 Handler := First_Non_Pragma (Exception_Handlers (N));
|
|
|
2453 while Present (Handler) loop
|
|
|
2454 Traverse_Declarations_Or_Statements
|
|
|
2455 (L => Statements (Handler),
|
|
|
2456 D => ('E', Handler));
|
|
|
2457 Next (Handler);
|
|
|
2458 end loop;
|
|
|
2459 end if;
|
|
|
2460 end if;
|
|
|
2461 end Traverse_Handled_Statement_Sequence;
|
|
|
2462
|
|
|
2463 ---------------------------
|
|
|
2464 -- Traverse_Package_Body --
|
|
|
2465 ---------------------------
|
|
|
2466
|
|
|
2467 procedure Traverse_Package_Body (N : Node_Id) is
|
|
|
2468 Dom : Dominant_Info;
|
|
|
2469 begin
|
|
|
2470 -- The first statement in the handled sequence of statements is
|
|
|
2471 -- dominated by the elaboration of the last declaration.
|
|
|
2472
|
|
|
2473 Dom := Traverse_Declarations_Or_Statements (Declarations (N));
|
|
|
2474
|
|
|
2475 Traverse_Handled_Statement_Sequence
|
|
|
2476 (Handled_Statement_Sequence (N), Dom);
|
|
|
2477 end Traverse_Package_Body;
|
|
|
2478
|
|
|
2479 ----------------------------------
|
|
|
2480 -- Traverse_Package_Declaration --
|
|
|
2481 ----------------------------------
|
|
|
2482
|
|
|
2483 procedure Traverse_Package_Declaration
|
|
|
2484 (N : Node_Id;
|
|
|
2485 D : Dominant_Info := No_Dominant)
|
|
|
2486 is
|
|
|
2487 Spec : constant Node_Id := Specification (N);
|
|
|
2488 Dom : Dominant_Info;
|
|
|
2489
|
|
|
2490 begin
|
|
|
2491 Dom :=
|
|
|
2492 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D);
|
|
|
2493
|
|
|
2494 -- First private declaration is dominated by last visible declaration
|
|
|
2495
|
|
|
2496 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
|
|
|
2497 end Traverse_Package_Declaration;
|
|
|
2498
|
|
|
2499 ------------------------------
|
|
|
2500 -- Traverse_Sync_Definition --
|
|
|
2501 ------------------------------
|
|
|
2502
|
|
|
2503 procedure Traverse_Sync_Definition (N : Node_Id) is
|
|
|
2504 Dom_Info : Dominant_Info := ('S', N);
|
|
|
2505 -- The first declaration is dominated by the protected or task [type]
|
|
|
2506 -- declaration.
|
|
|
2507
|
|
|
2508 Sync_Def : Node_Id;
|
|
|
2509 -- N's protected or task definition
|
|
|
2510
|
|
|
2511 Priv_Decl : List_Id;
|
|
|
2512 Vis_Decl : List_Id;
|
|
|
2513 -- Sync_Def's Visible_Declarations and Private_Declarations
|
|
|
2514
|
|
|
2515 begin
|
|
|
2516 case Nkind (N) is
|
|
|
2517 when N_Protected_Type_Declaration
|
|
|
2518 | N_Single_Protected_Declaration
|
|
|
2519 =>
|
|
|
2520 Sync_Def := Protected_Definition (N);
|
|
|
2521
|
|
|
2522 when N_Single_Task_Declaration
|
|
|
2523 | N_Task_Type_Declaration
|
|
|
2524 =>
|
|
|
2525 Sync_Def := Task_Definition (N);
|
|
|
2526
|
|
|
2527 when others =>
|
|
|
2528 raise Program_Error;
|
|
|
2529 end case;
|
|
|
2530
|
|
|
2531 -- Sync_Def may be Empty at least for empty Task_Type_Declarations.
|
|
|
2532 -- Querying Visible or Private_Declarations is invalid in this case.
|
|
|
2533
|
|
|
2534 if Present (Sync_Def) then
|
|
|
2535 Vis_Decl := Visible_Declarations (Sync_Def);
|
|
|
2536 Priv_Decl := Private_Declarations (Sync_Def);
|
|
|
2537 else
|
|
|
2538 Vis_Decl := No_List;
|
|
|
2539 Priv_Decl := No_List;
|
|
|
2540 end if;
|
|
|
2541
|
|
|
2542 Dom_Info := Traverse_Declarations_Or_Statements
|
|
|
2543 (L => Vis_Decl,
|
|
|
2544 D => Dom_Info);
|
|
|
2545
|
|
|
2546 -- If visible declarations are present, the first private declaration
|
|
|
2547 -- is dominated by the last visible declaration.
|
|
|
2548
|
|
|
2549 Traverse_Declarations_Or_Statements
|
|
|
2550 (L => Priv_Decl,
|
|
|
2551 D => Dom_Info);
|
|
|
2552 end Traverse_Sync_Definition;
|
|
|
2553
|
|
|
2554 --------------------------------------
|
|
|
2555 -- Traverse_Subprogram_Or_Task_Body --
|
|
|
2556 --------------------------------------
|
|
|
2557
|
|
|
2558 procedure Traverse_Subprogram_Or_Task_Body
|
|
|
2559 (N : Node_Id;
|
|
|
2560 D : Dominant_Info := No_Dominant)
|
|
|
2561 is
|
|
|
2562 Decls : constant List_Id := Declarations (N);
|
|
|
2563 Dom_Info : Dominant_Info := D;
|
|
|
2564
|
|
|
2565 begin
|
|
|
2566 -- If declarations are present, the first statement is dominated by the
|
|
|
2567 -- last declaration.
|
|
|
2568
|
|
|
2569 Dom_Info := Traverse_Declarations_Or_Statements
|
|
|
2570 (L => Decls, D => Dom_Info);
|
|
|
2571
|
|
|
2572 Traverse_Handled_Statement_Sequence
|
|
|
2573 (N => Handled_Statement_Sequence (N),
|
|
|
2574 D => Dom_Info);
|
|
|
2575 end Traverse_Subprogram_Or_Task_Body;
|
|
|
2576
|
|
|
2577 -------------------------
|
|
|
2578 -- SCO_Record_Filtered --
|
|
|
2579 -------------------------
|
|
|
2580
|
|
|
2581 procedure SCO_Record_Filtered is
|
|
|
2582 type Decision is record
|
|
|
2583 Kind : Character;
|
|
|
2584 -- Type of the SCO decision (see comments for SCO_Table_Entry.C1)
|
|
|
2585
|
|
|
2586 Sloc : Source_Location;
|
|
|
2587
|
|
|
2588 Top : Nat;
|
|
|
2589 -- Index in the SCO_Raw_Table for the root operator/condition for the
|
|
|
2590 -- expression that controls the decision.
|
|
|
2591 end record;
|
|
|
2592 -- Decision descriptor: used to gather information about a candidate
|
|
|
2593 -- SCO decision.
|
|
|
2594
|
|
|
2595 package Pending_Decisions is new Table.Table
|
|
|
2596 (Table_Component_Type => Decision,
|
|
|
2597 Table_Index_Type => Nat,
|
|
|
2598 Table_Low_Bound => 1,
|
|
|
2599 Table_Initial => 1000,
|
|
|
2600 Table_Increment => 200,
|
|
|
2601 Table_Name => "Filter_Pending_Decisions");
|
|
|
2602 -- Table used to hold decisions to process during the collection pass
|
|
|
2603
|
|
|
2604 procedure Add_Expression_Tree (Idx : in out Nat);
|
|
|
2605 -- Add SCO raw table entries for the decision controlling expression
|
|
|
2606 -- tree starting at Idx to the filtered SCO table.
|
|
|
2607
|
|
|
2608 procedure Collect_Decisions
|
|
|
2609 (D : Decision;
|
|
|
2610 Next : out Nat);
|
|
|
2611 -- Collect decisions to add to the filtered SCO table starting at the
|
|
|
2612 -- D decision (including it and its nested operators/conditions). Set
|
|
|
2613 -- Next to the first node index passed the whole decision.
|
|
|
2614
|
|
|
2615 procedure Compute_Range
|
|
|
2616 (Idx : in out Nat;
|
|
|
2617 From : out Source_Location;
|
|
|
2618 To : out Source_Location);
|
|
|
2619 -- Compute the source location range for the expression tree starting at
|
|
|
2620 -- Idx in the SCO raw table. Store its bounds in From and To.
|
|
|
2621
|
|
|
2622 function Is_Decision (Idx : Nat) return Boolean;
|
|
|
2623 -- Return if the expression tree starting at Idx has adjacent nested
|
|
|
2624 -- nodes that make a decision.
|
|
|
2625
|
|
|
2626 procedure Process_Pending_Decisions
|
|
|
2627 (Original_Decision : SCO_Table_Entry);
|
|
|
2628 -- Complete the filtered SCO table using collected decisions. Output
|
|
|
2629 -- decisions inherit the pragma information from the original decision.
|
|
|
2630
|
|
|
2631 procedure Search_Nested_Decisions (Idx : in out Nat);
|
|
|
2632 -- Collect decisions to add to the filtered SCO table starting at the
|
|
|
2633 -- node at Idx in the SCO raw table. This node must not be part of an
|
|
|
2634 -- already-processed decision. Set Idx to the first node index passed
|
|
|
2635 -- the whole expression tree.
|
|
|
2636
|
|
|
2637 procedure Skip_Decision
|
|
|
2638 (Idx : in out Nat;
|
|
|
2639 Process_Nested_Decisions : Boolean);
|
|
|
2640 -- Skip all the nodes that belong to the decision starting at Idx. If
|
|
|
2641 -- Process_Nested_Decision, call Search_Nested_Decisions on the first
|
|
|
2642 -- nested nodes that do not belong to the decision. Set Idx to the first
|
|
|
2643 -- node index passed the whole expression tree.
|
|
|
2644
|
|
|
2645 -------------------------
|
|
|
2646 -- Add_Expression_Tree --
|
|
|
2647 -------------------------
|
|
|
2648
|
|
|
2649 procedure Add_Expression_Tree (Idx : in out Nat) is
|
|
|
2650 Node_Idx : constant Nat := Idx;
|
|
|
2651 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
|
|
|
2652 From : Source_Location;
|
|
|
2653 To : Source_Location;
|
|
|
2654
|
|
|
2655 begin
|
|
|
2656 case T.C1 is
|
|
|
2657 when ' ' =>
|
|
|
2658
|
|
|
2659 -- This is a single condition. Add an entry for it and move on
|
|
|
2660
|
|
|
2661 SCO_Table.Append (T);
|
|
|
2662 Idx := Idx + 1;
|
|
|
2663
|
|
|
2664 when '!' =>
|
|
|
2665
|
|
|
2666 -- This is a NOT operator: add an entry for it and browse its
|
|
|
2667 -- only child.
|
|
|
2668
|
|
|
2669 SCO_Table.Append (T);
|
|
|
2670 Idx := Idx + 1;
|
|
|
2671 Add_Expression_Tree (Idx);
|
|
|
2672
|
|
|
2673 when others =>
|
|
|
2674
|
|
|
2675 -- This must be an AND/OR/AND THEN/OR ELSE operator
|
|
|
2676
|
|
|
2677 if T.C2 = '?' then
|
|
|
2678
|
|
|
2679 -- This is not a short circuit operator: consider this one
|
|
|
2680 -- and all its children as a single condition.
|
|
|
2681
|
|
|
2682 Compute_Range (Idx, From, To);
|
|
|
2683 SCO_Table.Append
|
|
|
2684 ((From => From,
|
|
|
2685 To => To,
|
|
|
2686 C1 => ' ',
|
|
|
2687 C2 => 'c',
|
|
|
2688 Last => False,
|
|
|
2689 Pragma_Sloc => No_Location,
|
|
|
2690 Pragma_Aspect_Name => No_Name));
|
|
|
2691
|
|
|
2692 else
|
|
|
2693 -- This is a real short circuit operator: add an entry for
|
|
|
2694 -- it and browse its children.
|
|
|
2695
|
|
|
2696 SCO_Table.Append (T);
|
|
|
2697 Idx := Idx + 1;
|
|
|
2698 Add_Expression_Tree (Idx);
|
|
|
2699 Add_Expression_Tree (Idx);
|
|
|
2700 end if;
|
|
|
2701 end case;
|
|
|
2702 end Add_Expression_Tree;
|
|
|
2703
|
|
|
2704 -----------------------
|
|
|
2705 -- Collect_Decisions --
|
|
|
2706 -----------------------
|
|
|
2707
|
|
|
2708 procedure Collect_Decisions
|
|
|
2709 (D : Decision;
|
|
|
2710 Next : out Nat)
|
|
|
2711 is
|
|
|
2712 Idx : Nat := D.Top;
|
|
|
2713
|
|
|
2714 begin
|
|
|
2715 if D.Kind /= 'X' or else Is_Decision (D.Top) then
|
|
|
2716 Pending_Decisions.Append (D);
|
|
|
2717 end if;
|
|
|
2718
|
|
|
2719 Skip_Decision (Idx, True);
|
|
|
2720 Next := Idx;
|
|
|
2721 end Collect_Decisions;
|
|
|
2722
|
|
|
2723 -------------------
|
|
|
2724 -- Compute_Range --
|
|
|
2725 -------------------
|
|
|
2726
|
|
|
2727 procedure Compute_Range
|
|
|
2728 (Idx : in out Nat;
|
|
|
2729 From : out Source_Location;
|
|
|
2730 To : out Source_Location)
|
|
|
2731 is
|
|
|
2732 Sloc_F : Source_Location := No_Source_Location;
|
|
|
2733 Sloc_T : Source_Location := No_Source_Location;
|
|
|
2734
|
|
|
2735 procedure Process_One;
|
|
|
2736 -- Process one node of the tree, and recurse over children. Update
|
|
|
2737 -- Idx during the traversal.
|
|
|
2738
|
|
|
2739 -----------------
|
|
|
2740 -- Process_One --
|
|
|
2741 -----------------
|
|
|
2742
|
|
|
2743 procedure Process_One is
|
|
|
2744 begin
|
|
|
2745 if Sloc_F = No_Source_Location
|
|
|
2746 or else
|
|
|
2747 SCO_Raw_Table.Table (Idx).From < Sloc_F
|
|
|
2748 then
|
|
|
2749 Sloc_F := SCO_Raw_Table.Table (Idx).From;
|
|
|
2750 end if;
|
|
|
2751
|
|
|
2752 if Sloc_T = No_Source_Location
|
|
|
2753 or else
|
|
|
2754 Sloc_T < SCO_Raw_Table.Table (Idx).To
|
|
|
2755 then
|
|
|
2756 Sloc_T := SCO_Raw_Table.Table (Idx).To;
|
|
|
2757 end if;
|
|
|
2758
|
|
|
2759 if SCO_Raw_Table.Table (Idx).C1 = ' ' then
|
|
|
2760
|
|
|
2761 -- This is a condition: nothing special to do
|
|
|
2762
|
|
|
2763 Idx := Idx + 1;
|
|
|
2764
|
|
|
2765 elsif SCO_Raw_Table.Table (Idx).C1 = '!' then
|
|
|
2766
|
|
|
2767 -- The "not" operator has only one operand
|
|
|
2768
|
|
|
2769 Idx := Idx + 1;
|
|
|
2770 Process_One;
|
|
|
2771
|
|
|
2772 else
|
|
|
2773 -- This is an AND THEN or OR ELSE logical operator: follow the
|
|
|
2774 -- left, then the right operands.
|
|
|
2775
|
|
|
2776 Idx := Idx + 1;
|
|
|
2777
|
|
|
2778 Process_One;
|
|
|
2779 Process_One;
|
|
|
2780 end if;
|
|
|
2781 end Process_One;
|
|
|
2782
|
|
|
2783 -- Start of processing for Compute_Range
|
|
|
2784
|
|
|
2785 begin
|
|
|
2786 Process_One;
|
|
|
2787 From := Sloc_F;
|
|
|
2788 To := Sloc_T;
|
|
|
2789 end Compute_Range;
|
|
|
2790
|
|
|
2791 -----------------
|
|
|
2792 -- Is_Decision --
|
|
|
2793 -----------------
|
|
|
2794
|
|
|
2795 function Is_Decision (Idx : Nat) return Boolean is
|
|
|
2796 Index : Nat := Idx;
|
|
|
2797
|
|
|
2798 begin
|
|
|
2799 loop
|
|
|
2800 declare
|
|
|
2801 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
|
|
|
2802
|
|
|
2803 begin
|
|
|
2804 case T.C1 is
|
|
|
2805 when ' ' =>
|
|
|
2806 return False;
|
|
|
2807
|
|
|
2808 when '!' =>
|
|
|
2809
|
|
|
2810 -- This is a decision iff the only operand of the NOT
|
|
|
2811 -- operator could be a standalone decision.
|
|
|
2812
|
|
|
2813 Index := Idx + 1;
|
|
|
2814
|
|
|
2815 when others =>
|
|
|
2816
|
|
|
2817 -- This node is a logical operator (and thus could be a
|
|
|
2818 -- standalone decision) iff it is a short circuit
|
|
|
2819 -- operator.
|
|
|
2820
|
|
|
2821 return T.C2 /= '?';
|
|
|
2822 end case;
|
|
|
2823 end;
|
|
|
2824 end loop;
|
|
|
2825 end Is_Decision;
|
|
|
2826
|
|
|
2827 -------------------------------
|
|
|
2828 -- Process_Pending_Decisions --
|
|
|
2829 -------------------------------
|
|
|
2830
|
|
|
2831 procedure Process_Pending_Decisions
|
|
|
2832 (Original_Decision : SCO_Table_Entry)
|
|
|
2833 is
|
|
|
2834 begin
|
|
|
2835 for Index in 1 .. Pending_Decisions.Last loop
|
|
|
2836 declare
|
|
|
2837 D : Decision renames Pending_Decisions.Table (Index);
|
|
|
2838 Idx : Nat := D.Top;
|
|
|
2839
|
|
|
2840 begin
|
|
|
2841 -- Add a SCO table entry for the decision itself
|
|
|
2842
|
|
|
2843 pragma Assert (D.Kind /= ' ');
|
|
|
2844
|
|
|
2845 SCO_Table.Append
|
|
|
2846 ((To => No_Source_Location,
|
|
|
2847 From => D.Sloc,
|
|
|
2848 C1 => D.Kind,
|
|
|
2849 C2 => ' ',
|
|
|
2850 Last => False,
|
|
|
2851 Pragma_Sloc => Original_Decision.Pragma_Sloc,
|
|
|
2852 Pragma_Aspect_Name =>
|
|
|
2853 Original_Decision.Pragma_Aspect_Name));
|
|
|
2854
|
|
|
2855 -- Then add ones for its nested operators/operands. Do not
|
|
|
2856 -- forget to tag its *last* entry as such.
|
|
|
2857
|
|
|
2858 Add_Expression_Tree (Idx);
|
|
|
2859 SCO_Table.Table (SCO_Table.Last).Last := True;
|
|
|
2860 end;
|
|
|
2861 end loop;
|
|
|
2862
|
|
|
2863 -- Clear the pending decisions list
|
|
|
2864 Pending_Decisions.Set_Last (0);
|
|
|
2865 end Process_Pending_Decisions;
|
|
|
2866
|
|
|
2867 -----------------------------
|
|
|
2868 -- Search_Nested_Decisions --
|
|
|
2869 -----------------------------
|
|
|
2870
|
|
|
2871 procedure Search_Nested_Decisions (Idx : in out Nat) is
|
|
|
2872 begin
|
|
|
2873 loop
|
|
|
2874 declare
|
|
|
2875 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
|
|
|
2876
|
|
|
2877 begin
|
|
|
2878 case T.C1 is
|
|
|
2879 when ' ' =>
|
|
|
2880 Idx := Idx + 1;
|
|
|
2881 exit;
|
|
|
2882
|
|
|
2883 when '!' =>
|
|
|
2884 Collect_Decisions
|
|
|
2885 ((Kind => 'X',
|
|
|
2886 Sloc => T.From,
|
|
|
2887 Top => Idx),
|
|
|
2888 Idx);
|
|
|
2889 exit;
|
|
|
2890
|
|
|
2891 when others =>
|
|
|
2892 if T.C2 = '?' then
|
|
|
2893
|
|
|
2894 -- This is not a logical operator: start looking for
|
|
|
2895 -- nested decisions from here. Recurse over the left
|
|
|
2896 -- child and let the loop take care of the right one.
|
|
|
2897
|
|
|
2898 Idx := Idx + 1;
|
|
|
2899 Search_Nested_Decisions (Idx);
|
|
|
2900
|
|
|
2901 else
|
|
|
2902 -- We found a nested decision
|
|
|
2903
|
|
|
2904 Collect_Decisions
|
|
|
2905 ((Kind => 'X',
|
|
|
2906 Sloc => T.From,
|
|
|
2907 Top => Idx),
|
|
|
2908 Idx);
|
|
|
2909 exit;
|
|
|
2910 end if;
|
|
|
2911 end case;
|
|
|
2912 end;
|
|
|
2913 end loop;
|
|
|
2914 end Search_Nested_Decisions;
|
|
|
2915
|
|
|
2916 -------------------
|
|
|
2917 -- Skip_Decision --
|
|
|
2918 -------------------
|
|
|
2919
|
|
|
2920 procedure Skip_Decision
|
|
|
2921 (Idx : in out Nat;
|
|
|
2922 Process_Nested_Decisions : Boolean)
|
|
|
2923 is
|
|
|
2924 begin
|
|
|
2925 loop
|
|
|
2926 declare
|
|
|
2927 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
|
|
|
2928
|
|
|
2929 begin
|
|
|
2930 Idx := Idx + 1;
|
|
|
2931
|
|
|
2932 case T.C1 is
|
|
|
2933 when ' ' =>
|
|
|
2934 exit;
|
|
|
2935
|
|
|
2936 when '!' =>
|
|
|
2937
|
|
|
2938 -- This NOT operator belongs to the outside decision:
|
|
|
2939 -- just skip it.
|
|
|
2940
|
|
|
2941 null;
|
|
|
2942
|
|
|
2943 when others =>
|
|
|
2944 if T.C2 = '?' and then Process_Nested_Decisions then
|
|
|
2945
|
|
|
2946 -- This is not a logical operator: start looking for
|
|
|
2947 -- nested decisions from here. Recurse over the left
|
|
|
2948 -- child and let the loop take care of the right one.
|
|
|
2949
|
|
|
2950 Search_Nested_Decisions (Idx);
|
|
|
2951
|
|
|
2952 else
|
|
|
2953 -- This is a logical operator, so it belongs to the
|
|
|
2954 -- outside decision: skip its left child, then let the
|
|
|
2955 -- loop take care of the right one.
|
|
|
2956
|
|
|
2957 Skip_Decision (Idx, Process_Nested_Decisions);
|
|
|
2958 end if;
|
|
|
2959 end case;
|
|
|
2960 end;
|
|
|
2961 end loop;
|
|
|
2962 end Skip_Decision;
|
|
|
2963
|
|
|
2964 -- Start of processing for SCO_Record_Filtered
|
|
|
2965
|
|
|
2966 begin
|
|
|
2967 -- Filtering must happen only once: do nothing if it this pass was
|
|
|
2968 -- already run.
|
|
|
2969
|
|
|
2970 if SCO_Generation_State = Filtered then
|
|
|
2971 return;
|
|
|
2972 else
|
|
|
2973 pragma Assert (SCO_Generation_State = Raw);
|
|
|
2974 SCO_Generation_State := Filtered;
|
|
|
2975 end if;
|
|
|
2976
|
|
|
2977 -- Loop through all SCO entries under SCO units
|
|
|
2978
|
|
|
2979 for Unit_Idx in 1 .. SCO_Unit_Table.Last loop
|
|
|
2980 declare
|
|
|
2981 Unit : SCO_Unit_Table_Entry
|
|
|
2982 renames SCO_Unit_Table.Table (Unit_Idx);
|
|
|
2983
|
|
|
2984 Idx : Nat := Unit.From;
|
|
|
2985 -- Index of the current SCO raw table entry
|
|
|
2986
|
|
|
2987 New_From : constant Nat := SCO_Table.Last + 1;
|
|
|
2988 -- After copying SCO enties of interest to the final table, we
|
|
|
2989 -- will have to change the From/To indexes this unit targets.
|
|
|
2990 -- This constant keeps track of the new From index.
|
|
|
2991
|
|
|
2992 begin
|
|
|
2993 while Idx <= Unit.To loop
|
|
|
2994 declare
|
|
|
2995 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
|
|
|
2996
|
|
|
2997 begin
|
|
|
2998 case T.C1 is
|
|
|
2999
|
|
|
3000 -- Decision (of any kind, including pragmas and aspects)
|
|
|
3001
|
|
|
3002 when 'E' | 'G' | 'I' | 'W' | 'X' | 'P' | 'a' | 'A' =>
|
|
|
3003 if SCO_Pragma_Disabled (T.Pragma_Sloc) then
|
|
|
3004
|
|
|
3005 -- Skip SCO entries for decisions in disabled
|
|
|
3006 -- constructs (pragmas or aspects).
|
|
|
3007
|
|
|
3008 Idx := Idx + 1;
|
|
|
3009 Skip_Decision (Idx, False);
|
|
|
3010
|
|
|
3011 else
|
|
|
3012 Collect_Decisions
|
|
|
3013 ((Kind => T.C1,
|
|
|
3014 Sloc => T.From,
|
|
|
3015 Top => Idx + 1),
|
|
|
3016 Idx);
|
|
|
3017 Process_Pending_Decisions (T);
|
|
|
3018 end if;
|
|
|
3019
|
|
|
3020 -- There is no translation/filtering to do for other kind
|
|
|
3021 -- of SCO items (statements, dominance markers, etc.).
|
|
|
3022
|
|
|
3023 when '|' | '&' | '!' | ' ' =>
|
|
|
3024
|
|
|
3025 -- SCO logical operators and conditions cannot exist
|
|
|
3026 -- on their own: they must be inside a decision (such
|
|
|
3027 -- entries must have been skipped by
|
|
|
3028 -- Collect_Decisions).
|
|
|
3029
|
|
|
3030 raise Program_Error;
|
|
|
3031
|
|
|
3032 when others =>
|
|
|
3033 SCO_Table.Append (T);
|
|
|
3034 Idx := Idx + 1;
|
|
|
3035 end case;
|
|
|
3036 end;
|
|
|
3037 end loop;
|
|
|
3038
|
|
|
3039 -- Now, update the SCO entry indexes in the unit entry
|
|
|
3040
|
|
|
3041 Unit.From := New_From;
|
|
|
3042 Unit.To := SCO_Table.Last;
|
|
|
3043 end;
|
|
|
3044 end loop;
|
|
|
3045
|
|
|
3046 -- Then clear the raw table to free bytes
|
|
|
3047
|
|
|
3048 SCO_Raw_Table.Free;
|
|
|
3049 end SCO_Record_Filtered;
|
|
|
3050
|
|
|
3051 end Par_SCO;
|
