]>
Commit | Line | Data |
---|---|---|
6f12117a RD |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- P A R _ S C O -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 2009-2020, Free Software Foundation, Inc. -- |
6f12117a RD |
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 | ||
06ad40d3 | 26 | with Aspects; use Aspects; |
6f12117a RD |
27 | with Atree; use Atree; |
28 | with Debug; use Debug; | |
473e20df | 29 | with Errout; use Errout; |
6f12117a RD |
30 | with Lib; use Lib; |
31 | with Lib.Util; use Lib.Util; | |
240fe2a4 | 32 | with Namet; use Namet; |
6f12117a | 33 | with Nlists; use Nlists; |
892125cd | 34 | with Opt; use Opt; |
6f12117a | 35 | with Output; use Output; |
f7f0159d | 36 | with Put_SCOs; |
240fe2a4 | 37 | with SCOs; use SCOs; |
150ac76e AC |
38 | with Sem; use Sem; |
39 | with Sem_Util; use Sem_Util; | |
6f12117a RD |
40 | with Sinfo; use Sinfo; |
41 | with Sinput; use Sinput; | |
65564d08 | 42 | with Snames; use Snames; |
6f12117a RD |
43 | with Table; |
44 | ||
892125cd AC |
45 | with GNAT.HTable; use GNAT.HTable; |
46 | with GNAT.Heap_Sort_G; | |
6f12117a RD |
47 | |
48 | package body Par_SCO is | |
49 | ||
0566484a AC |
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 | ||
9fb1e654 | 78 | package SCO_Raw_Table is new Table.Table |
009c0268 AC |
79 | (Table_Component_Type => SCO_Table_Entry, |
80 | Table_Index_Type => Nat, | |
81 | Table_Low_Bound => 1, | |
82 | Table_Initial => 500, | |
9fb1e654 AC |
83 | Table_Increment => 300, |
84 | Table_Name => "Raw_Table"); | |
0566484a | 85 | |
240fe2a4 AC |
86 | ----------------------- |
87 | -- Unit Number Table -- | |
88 | ----------------------- | |
6f12117a | 89 | |
240fe2a4 AC |
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. | |
6f12117a | 94 | |
31fde973 GD |
95 | -- Note that the zeroth entry is here for convenience in sorting the table; |
96 | -- the real lower bound is 1. | |
6f12117a | 97 | |
009c0268 AC |
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"); | |
6f12117a | 105 | |
0566484a AC |
106 | ------------------------------------------ |
107 | -- Condition/Operator/Pragma Hash Table -- | |
108 | ------------------------------------------ | |
6f12117a RD |
109 | |
110 | -- We need to be able to get to conditions quickly for handling the calls | |
b26be063 | 111 | -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to |
0566484a AC |
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 | |
727e7b1a | 115 | -- hash table to map from these sloc values to SCO_Table indexes. |
6f12117a RD |
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 | ||
009c0268 | 123 | function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean; |
6f12117a RD |
124 | -- Function to test two keys for equality |
125 | ||
009c0268 | 126 | function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean; |
0566484a AC |
127 | -- Function to test for source locations order |
128 | ||
129 | package SCO_Raw_Hash_Table is new Simple_HTable | |
6f12117a RD |
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). | |
0566484a AC |
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. | |
6f12117a | 146 | |
0566484a AC |
147 | type Tristate is (False, True, Unknown); |
148 | ||
149 | function Is_Logical_Operator (N : Node_Id) return Tristate; | |
e191e5ae | 150 | -- N is the node for a subexpression. This procedure determines whether N |
0566484a AC |
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. | |
6f12117a | 155 | |
cf427f02 AC |
156 | function To_Source_Location (S : Source_Ptr) return Source_Location; |
157 | -- Converts Source_Ptr value to Source_Location (line/col) format | |
158 | ||
44a10091 AC |
159 | procedure Process_Decisions |
160 | (N : Node_Id; | |
161 | T : Character; | |
162 | Pragma_Sloc : Source_Ptr); | |
6f12117a | 163 | -- If N is Empty, has no effect. Otherwise scans the tree for the node N, |
7ab4d95a AC |
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 | |
9b16cb57 RD |
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). | |
6f12117a | 169 | |
44a10091 AC |
170 | procedure Process_Decisions |
171 | (L : List_Id; | |
172 | T : Character; | |
173 | Pragma_Sloc : Source_Ptr); | |
892125cd AC |
174 | -- Calls above procedure for each element of the list L |
175 | ||
0566484a | 176 | procedure Set_Raw_Table_Entry |
06ad40d3 AC |
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); | |
0566484a | 184 | -- Append an entry to SCO_Raw_Table with fields set as per arguments |
6f12117a | 185 | |
3128f955 AC |
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; | |
727e7b1a | 191 | -- Node providing the Sloc(s) for the dominance marker |
3128f955 AC |
192 | end record; |
193 | No_Dominant : constant Dominant_Info := (' ', Empty); | |
194 | ||
cf427f02 AC |
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 | ||
3128f955 AC |
198 | procedure Traverse_Declarations_Or_Statements |
199 | (L : List_Id; | |
727e7b1a AC |
200 | D : Dominant_Info := No_Dominant; |
201 | P : Node_Id := Empty); | |
009c0268 AC |
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. | |
3128f955 | 204 | |
dd2d73a7 AC |
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 | ||
7130729a | 212 | -- The following Traverse_* routines perform appropriate calls to |
9b23b7de RD |
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 | ||
83b77c5c AC |
217 | -- Why is Traverse_Sync_Definition commented specifically, whereas |
218 | -- the others are not??? | |
7130729a | 219 | |
892125cd | 220 | procedure Traverse_Generic_Package_Declaration (N : Node_Id); |
009c0268 | 221 | |
3128f955 AC |
222 | procedure Traverse_Handled_Statement_Sequence |
223 | (N : Node_Id; | |
224 | D : Dominant_Info := No_Dominant); | |
009c0268 AC |
225 | |
226 | procedure Traverse_Package_Body (N : Node_Id); | |
227 | ||
ef7c5fa9 AC |
228 | procedure Traverse_Package_Declaration |
229 | (N : Node_Id; | |
230 | D : Dominant_Info := No_Dominant); | |
009c0268 | 231 | |
76264f60 AC |
232 | procedure Traverse_Subprogram_Or_Task_Body |
233 | (N : Node_Id; | |
234 | D : Dominant_Info := No_Dominant); | |
7130729a | 235 | |
009c0268 | 236 | procedure Traverse_Sync_Definition (N : Node_Id); |
7130729a | 237 | -- Traverse a protected definition or task definition |
6f12117a | 238 | |
009c0268 AC |
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 | ||
240fe2a4 AC |
246 | procedure Write_SCOs_To_ALI_File is new Put_SCOs; |
247 | -- Write SCO information to the ALI file using routines in Lib.Util | |
6f12117a RD |
248 | |
249 | ---------- | |
250 | -- dsco -- | |
251 | ---------- | |
252 | ||
253 | procedure dsco is | |
0566484a AC |
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 | ||
6f12117a | 304 | begin |
240fe2a4 AC |
305 | -- Dump SCO unit table |
306 | ||
6f12117a RD |
307 | Write_Line ("SCO Unit Table"); |
308 | Write_Line ("--------------"); | |
309 | ||
240fe2a4 AC |
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)); | |
0566484a | 317 | Write_Str (" Dep_Num = "); |
240fe2a4 AC |
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; | |
6f12117a RD |
333 | end loop; |
334 | ||
240fe2a4 AC |
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 | ||
0566484a | 351 | -- Dump SCO raw-table |
240fe2a4 | 352 | |
6f12117a | 353 | Write_Eol; |
0566484a | 354 | Write_Line ("SCO Raw Table"); |
6f12117a RD |
355 | Write_Line ("---------"); |
356 | ||
0566484a AC |
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; | |
240fe2a4 | 364 | |
0566484a | 365 | -- Dump SCO table itself |
6f12117a | 366 | |
0566484a AC |
367 | Write_Eol; |
368 | Write_Line ("SCO Filtered Table"); | |
369 | Write_Line ("---------"); | |
6f12117a | 370 | |
0566484a AC |
371 | for Index in 1 .. SCO_Table.Last loop |
372 | Dump_Entry (Index, SCO_Table.Table (Index)); | |
6f12117a RD |
373 | end loop; |
374 | end dsco; | |
375 | ||
376 | ----------- | |
377 | -- Equal -- | |
378 | ----------- | |
379 | ||
009c0268 | 380 | function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean is |
6f12117a RD |
381 | begin |
382 | return F1 = F2; | |
383 | end Equal; | |
384 | ||
0566484a AC |
385 | ------- |
386 | -- < -- | |
387 | ------- | |
388 | ||
009c0268 | 389 | function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean is |
0566484a AC |
390 | begin |
391 | return S1.Line < S2.Line | |
392 | or else (S1.Line = S2.Line and then S1.Col < S2.Col); | |
393 | end "<"; | |
394 | ||
6f12117a RD |
395 | ------------------ |
396 | -- Has_Decision -- | |
397 | ------------------ | |
398 | ||
399 | function Has_Decision (N : Node_Id) return Boolean is | |
6f12117a | 400 | function Check_Node (N : Node_Id) return Traverse_Result; |
009c0268 AC |
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 | |
8b034336 | 403 | -- IF-expression whose Condition attribute is a decision). |
6f12117a RD |
404 | |
405 | ---------------- | |
406 | -- Check_Node -- | |
407 | ---------------- | |
408 | ||
409 | function Check_Node (N : Node_Id) return Traverse_Result is | |
410 | begin | |
0566484a AC |
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 | |
009c0268 | 417 | or else Nkind (N) = N_If_Expression |
0566484a | 418 | then |
6f12117a RD |
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 | ||
892125cd AC |
442 | ---------------- |
443 | -- Initialize -- | |
444 | ---------------- | |
6f12117a | 445 | |
892125cd | 446 | procedure Initialize is |
6f12117a | 447 | begin |
240fe2a4 AC |
448 | SCO_Unit_Number_Table.Init; |
449 | ||
e191e5ae TQ |
450 | -- The SCO_Unit_Number_Table entry with index 0 is intentionally set |
451 | -- aside to be used as temporary for sorting. | |
240fe2a4 AC |
452 | |
453 | SCO_Unit_Number_Table.Increment_Last; | |
892125cd | 454 | end Initialize; |
6f12117a RD |
455 | |
456 | ------------------------- | |
457 | -- Is_Logical_Operator -- | |
458 | ------------------------- | |
459 | ||
0566484a | 460 | function Is_Logical_Operator (N : Node_Id) return Tristate is |
6f12117a | 461 | begin |
009c0268 | 462 | if Nkind_In (N, N_And_Then, N_Op_Not, N_Or_Else) then |
0566484a AC |
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; | |
6f12117a RD |
469 | end Is_Logical_Operator; |
470 | ||
471 | ----------------------- | |
472 | -- Process_Decisions -- | |
473 | ----------------------- | |
474 | ||
892125cd AC |
475 | -- Version taking a list |
476 | ||
44a10091 AC |
477 | procedure Process_Decisions |
478 | (L : List_Id; | |
479 | T : Character; | |
480 | Pragma_Sloc : Source_Ptr) | |
481 | is | |
892125cd | 482 | N : Node_Id; |
009c0268 | 483 | |
892125cd AC |
484 | begin |
485 | if L /= No_List then | |
486 | N := First (L); | |
487 | while Present (N) loop | |
44a10091 | 488 | Process_Decisions (N, T, Pragma_Sloc); |
892125cd AC |
489 | Next (N); |
490 | end loop; | |
491 | end if; | |
492 | end Process_Decisions; | |
493 | ||
494 | -- Version taking a node | |
495 | ||
44a10091 AC |
496 | Current_Pragma_Sloc : Source_Ptr := No_Location; |
497 | -- While processing a pragma, this is set to the sloc of the N_Pragma node | |
892125cd | 498 | |
44a10091 AC |
499 | procedure Process_Decisions |
500 | (N : Node_Id; | |
501 | T : Character; | |
502 | Pragma_Sloc : Source_Ptr) | |
503 | is | |
25adc5fb AC |
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 | ||
50ef946c AC |
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 | ||
009c0268 AC |
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"); | |
50ef946c AC |
532 | -- Hold temporarily (i.e. free'd before returning) the Hash_Entry before |
533 | -- they are registered in SCO_Raw_Hash_Table. | |
534 | ||
25adc5fb AC |
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 | ||
6f12117a RD |
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 | ||
25adc5fb | 550 | procedure Output_Element (N : Node_Id); |
6f12117a RD |
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 | |
25adc5fb AC |
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. | |
6f12117a RD |
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 | ||
009c0268 AC |
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 | ||
6f12117a RD |
570 | ----------------------------- |
571 | -- Output_Decision_Operand -- | |
572 | ----------------------------- | |
573 | ||
574 | procedure Output_Decision_Operand (N : Node_Id) is | |
009c0268 AC |
575 | C1 : Character; |
576 | C2 : Character; | |
0566484a AC |
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 | ||
009c0268 AC |
582 | L : Node_Id; |
583 | T : Tristate; | |
6f12117a | 584 | |
6f12117a RD |
585 | begin |
586 | if No (N) then | |
587 | return; | |
0566484a AC |
588 | end if; |
589 | ||
590 | T := Is_Logical_Operator (N); | |
6f12117a RD |
591 | |
592 | -- Logical operator | |
593 | ||
0566484a | 594 | if T /= False then |
6f12117a | 595 | if Nkind (N) = N_Op_Not then |
0566484a | 596 | C1 := '!'; |
6f12117a RD |
597 | L := Empty; |
598 | ||
599 | else | |
600 | L := Left_Opnd (N); | |
601 | ||
25adc5fb | 602 | if Nkind_In (N, N_Op_Or, N_Or_Else) then |
0566484a | 603 | C1 := '|'; |
e191e5ae | 604 | else pragma Assert (Nkind_In (N, N_Op_And, N_And_Then)); |
0566484a | 605 | C1 := '&'; |
6f12117a RD |
606 | end if; |
607 | end if; | |
608 | ||
0566484a AC |
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, | |
25adc5fb AC |
618 | From => Sloc (N), |
619 | To => No_Location, | |
25adc5fb | 620 | Last => False); |
6f12117a | 621 | |
50ef946c | 622 | Hash_Entries.Append ((Sloc (N), SCO_Raw_Table.Last)); |
0566484a | 623 | |
6f12117a RD |
624 | Output_Decision_Operand (L); |
625 | Output_Decision_Operand (Right_Opnd (N)); | |
626 | ||
627 | -- Not a logical operator | |
628 | ||
629 | else | |
25adc5fb | 630 | Output_Element (N); |
6f12117a RD |
631 | end if; |
632 | end Output_Decision_Operand; | |
633 | ||
634 | -------------------- | |
635 | -- Output_Element -- | |
636 | -------------------- | |
637 | ||
25adc5fb | 638 | procedure Output_Element (N : Node_Id) is |
6f12117a RD |
639 | FSloc : Source_Ptr; |
640 | LSloc : Source_Ptr; | |
641 | begin | |
642 | Sloc_Range (N, FSloc, LSloc); | |
0566484a | 643 | Set_Raw_Table_Entry |
25adc5fb AC |
644 | (C1 => ' ', |
645 | C2 => 'c', | |
646 | From => FSloc, | |
647 | To => LSloc, | |
25adc5fb | 648 | Last => False); |
50ef946c | 649 | Hash_Entries.Append ((FSloc, SCO_Raw_Table.Last)); |
6f12117a RD |
650 | end Output_Element; |
651 | ||
25adc5fb AC |
652 | ------------------- |
653 | -- Output_Header -- | |
654 | ------------------- | |
655 | ||
656 | procedure Output_Header (T : Character) is | |
2c1b72d7 | 657 | Loc : Source_Ptr := No_Location; |
727e7b1a | 658 | -- Node whose Sloc is used for the decision |
5ffe0bab | 659 | |
06ad40d3 AC |
660 | Nam : Name_Id := No_Name; |
661 | -- For the case of an aspect, aspect name | |
662 | ||
25adc5fb AC |
663 | begin |
664 | case T is | |
1c66c4f5 | 665 | when 'I' | 'E' | 'W' | 'a' | 'A' => |
25adc5fb | 666 | |
06ad40d3 AC |
667 | -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of |
668 | -- the parent of the expression. | |
25adc5fb | 669 | |
5ffe0bab | 670 | Loc := Sloc (Parent (N)); |
25adc5fb | 671 | |
1c66c4f5 | 672 | if T = 'a' or else T = 'A' then |
06ad40d3 AC |
673 | Nam := Chars (Identifier (Parent (N))); |
674 | end if; | |
675 | ||
5ffe0bab | 676 | when 'G' | 'P' => |
25adc5fb | 677 | |
727e7b1a AC |
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. | |
29ba9f52 RD |
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 ??? | |
727e7b1a AC |
690 | |
691 | if Nkind_In (Parent (N), N_Accept_Alternative, | |
692 | N_Delay_Alternative, | |
693 | N_Terminate_Alternative) | |
694 | then | |
473e20df | 695 | Loc := First_Sloc (N); |
727e7b1a AC |
696 | else |
697 | Loc := Sloc (Parent (Parent (N))); | |
698 | end if; | |
25adc5fb AC |
699 | |
700 | when 'X' => | |
701 | ||
702 | -- For an expression, no Sloc | |
703 | ||
5ffe0bab | 704 | null; |
25adc5fb AC |
705 | |
706 | -- No other possibilities | |
707 | ||
708 | when others => | |
709 | raise Program_Error; | |
710 | end case; | |
5ffe0bab | 711 | |
0566484a | 712 | Set_Raw_Table_Entry |
06ad40d3 AC |
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 | |
50ef946c | 725 | Hash_Entries.Append ((Loc, SCO_Raw_Table.Last)); |
06ad40d3 | 726 | end if; |
25adc5fb AC |
727 | end Output_Header; |
728 | ||
6f12117a RD |
729 | ------------------------------ |
730 | -- Process_Decision_Operand -- | |
731 | ------------------------------ | |
732 | ||
733 | procedure Process_Decision_Operand (N : Node_Id) is | |
734 | begin | |
0566484a | 735 | if Is_Logical_Operator (N) /= False then |
6f12117a RD |
736 | if Nkind (N) /= N_Op_Not then |
737 | Process_Decision_Operand (Left_Opnd (N)); | |
25adc5fb | 738 | X_Not_Decision := False; |
6f12117a RD |
739 | end if; |
740 | ||
741 | Process_Decision_Operand (Right_Opnd (N)); | |
742 | ||
743 | else | |
44a10091 | 744 | Process_Decisions (N, 'X', Pragma_Sloc); |
6f12117a RD |
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 | ||
7ab4d95a AC |
756 | -- Logical operators, output table entries and then process |
757 | -- operands recursively to deal with nested conditions. | |
6f12117a | 758 | |
d8f43ee6 HK |
759 | when N_And_Then |
760 | | N_Op_And | |
761 | | N_Op_Not | |
762 | | N_Op_Or | |
763 | | N_Or_Else | |
764 | => | |
6f12117a RD |
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 | ||
25adc5fb | 780 | X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not; |
009c0268 | 781 | Mark := SCO_Raw_Table.Last; |
50ef946c | 782 | Mark_Hash := Hash_Entries.Last; |
25adc5fb | 783 | Output_Header (T); |
6f12117a RD |
784 | |
785 | -- Output the decision | |
786 | ||
787 | Output_Decision_Operand (N); | |
788 | ||
25adc5fb AC |
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. | |
6f12117a | 792 | |
25adc5fb | 793 | if X_Not_Decision then |
0566484a | 794 | SCO_Raw_Table.Set_Last (Mark); |
50ef946c | 795 | Hash_Entries.Set_Last (Mark_Hash); |
25adc5fb AC |
796 | |
797 | -- Otherwise, set Last in last table entry to mark end | |
798 | ||
799 | else | |
0566484a | 800 | SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True; |
25adc5fb | 801 | end if; |
6f12117a RD |
802 | |
803 | -- Process any embedded decisions | |
804 | ||
805 | Process_Decision_Operand (N); | |
806 | return Skip; | |
807 | end; | |
808 | ||
19d846a0 RD |
809 | -- Case expression |
810 | ||
9b16cb57 RD |
811 | -- Really hard to believe this is correct given the special |
812 | -- handling for if expressions below ??? | |
813 | ||
19d846a0 RD |
814 | when N_Case_Expression => |
815 | return OK; -- ??? | |
816 | ||
9b16cb57 | 817 | -- If expression, processed like an if statement |
6f12117a | 818 | |
9b16cb57 | 819 | when N_If_Expression => |
6f12117a RD |
820 | declare |
821 | Cond : constant Node_Id := First (Expressions (N)); | |
822 | Thnx : constant Node_Id := Next (Cond); | |
823 | Elsx : constant Node_Id := Next (Thnx); | |
009c0268 | 824 | |
6f12117a | 825 | begin |
44a10091 AC |
826 | Process_Decisions (Cond, 'I', Pragma_Sloc); |
827 | Process_Decisions (Thnx, 'X', Pragma_Sloc); | |
828 | Process_Decisions (Elsx, 'X', Pragma_Sloc); | |
6f12117a RD |
829 | return Skip; |
830 | end; | |
831 | ||
832 | -- All other cases, continue scan | |
833 | ||
834 | when others => | |
835 | return OK; | |
6f12117a RD |
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 | ||
50ef946c AC |
848 | Hash_Entries.Init; |
849 | ||
6f12117a RD |
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 | |
25adc5fb AC |
853 | -- or short circuit form) appearing as the operand of an IF, WHILE, |
854 | -- EXIT WHEN, or special PRAGMA construct. | |
6f12117a | 855 | |
0566484a | 856 | if T /= 'X' and then Is_Logical_Operator (N) = False then |
25adc5fb AC |
857 | Output_Header (T); |
858 | Output_Element (N); | |
6f12117a RD |
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 | ||
0566484a | 863 | SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True; |
6f12117a RD |
864 | end if; |
865 | ||
866 | Traverse (N); | |
50ef946c AC |
867 | |
868 | -- Now we have the definitive set of SCO entries, register them in the | |
869 | -- corresponding hash table. | |
870 | ||
cbc61965 | 871 | for J in 1 .. Hash_Entries.Last loop |
50ef946c | 872 | SCO_Raw_Hash_Table.Set |
cbc61965 AC |
873 | (Hash_Entries.Table (J).Sloc, |
874 | Hash_Entries.Table (J).SCO_Index); | |
50ef946c | 875 | end loop; |
cbc61965 | 876 | |
50ef946c | 877 | Hash_Entries.Free; |
6f12117a RD |
878 | end Process_Decisions; |
879 | ||
f7f0159d AC |
880 | ----------- |
881 | -- pscos -- | |
882 | ----------- | |
883 | ||
884 | procedure pscos is | |
f7f0159d AC |
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 | ||
7ab4d95a | 908 | -- Start of processing for pscos |
f7f0159d AC |
909 | |
910 | begin | |
911 | Debug_Put_SCOs; | |
912 | end pscos; | |
913 | ||
cf427f02 AC |
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)))); | |
009c0268 | 926 | |
cf427f02 AC |
927 | pragma Assert |
928 | (SCO_Instance_Table.Last = SCO_Instance_Index (Id)); | |
929 | end Record_Instance; | |
930 | ||
6f12117a RD |
931 | ---------------- |
932 | -- SCO_Output -- | |
933 | ---------------- | |
934 | ||
00838d9a | 935 | procedure SCO_Output is |
cf427f02 AC |
936 | procedure Populate_SCO_Instance_Table is |
937 | new Sinput.Iterate_On_Instances (Record_Instance); | |
009c0268 | 938 | |
6f12117a | 939 | begin |
0566484a AC |
940 | pragma Assert (SCO_Generation_State = Filtered); |
941 | ||
6f12117a RD |
942 | if Debug_Flag_Dot_OO then |
943 | dsco; | |
944 | end if; | |
945 | ||
cf427f02 AC |
946 | Populate_SCO_Instance_Table; |
947 | ||
240fe2a4 | 948 | -- Sort the unit tables based on dependency numbers |
892125cd AC |
949 | |
950 | Unit_Table_Sort : declare | |
009c0268 | 951 | function Lt (Op1 : Natural; Op2 : Natural) return Boolean; |
892125cd AC |
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 | ||
009c0268 | 961 | function Lt (Op1 : Natural; Op2 : Natural) return Boolean is |
892125cd | 962 | begin |
240fe2a4 AC |
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))); | |
892125cd AC |
969 | end Lt; |
970 | ||
971 | ---------- | |
972 | -- Move -- | |
973 | ---------- | |
974 | ||
975 | procedure Move (From : Natural; To : Natural) is | |
976 | begin | |
240fe2a4 AC |
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)); | |
892125cd AC |
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 | ||
240fe2a4 AC |
991 | -- Loop through entries in the unit table to set file name and |
992 | -- dependency number entries. | |
6f12117a | 993 | |
892125cd | 994 | for J in 1 .. SCO_Unit_Table.Last loop |
240fe2a4 AC |
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); | |
009c0268 | 998 | |
240fe2a4 AC |
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; | |
6f12117a | 1005 | |
240fe2a4 | 1006 | -- Now the tables are all setup for output to the ALI file |
6f12117a | 1007 | |
240fe2a4 | 1008 | Write_SCOs_To_ALI_File; |
6f12117a RD |
1009 | end SCO_Output; |
1010 | ||
c2873f74 TQ |
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 | ||
0566484a | 1023 | Index := SCO_Raw_Hash_Table.Get (Loc); |
c2873f74 | 1024 | |
8fb3f5df AC |
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. | |
c2873f74 TQ |
1029 | |
1030 | if Index /= 0 then | |
44a10091 | 1031 | declare |
0566484a AC |
1032 | T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index); |
1033 | ||
44a10091 | 1034 | begin |
06ad40d3 AC |
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; | |
44a10091 | 1059 | end; |
c2873f74 TQ |
1060 | |
1061 | else | |
1062 | return False; | |
1063 | end if; | |
1064 | end SCO_Pragma_Disabled; | |
1065 | ||
0566484a AC |
1066 | -------------------- |
1067 | -- SCO_Record_Raw -- | |
1068 | -------------------- | |
6f12117a | 1069 | |
0566484a | 1070 | procedure SCO_Record_Raw (U : Unit_Number_Type) is |
37c1f923 | 1071 | procedure Traverse_Aux_Decls (N : Node_Id); |
a532f98b | 1072 | -- Traverse the Aux_Decls_Node of compilation unit N |
37c1f923 AC |
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); | |
009c0268 | 1080 | |
37c1f923 AC |
1081 | begin |
1082 | Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); | |
37c1f923 | 1083 | Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); |
a532f98b AC |
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))); | |
37c1f923 AC |
1091 | end Traverse_Aux_Decls; |
1092 | ||
009c0268 AC |
1093 | -- Local variables |
1094 | ||
1095 | From : Nat; | |
1096 | Lu : Node_Id; | |
1097 | ||
0566484a | 1098 | -- Start of processing for SCO_Record_Raw |
37c1f923 | 1099 | |
6f12117a | 1100 | begin |
0566484a AC |
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 | ||
892125cd AC |
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 | ||
240fe2a4 AC |
1115 | for J in 1 .. SCO_Unit_Number_Table.Last loop |
1116 | if U = SCO_Unit_Number_Table.Table (J) then | |
892125cd AC |
1117 | return; |
1118 | end if; | |
1119 | end loop; | |
1120 | ||
1121 | -- Otherwise record starting entry | |
1122 | ||
0566484a | 1123 | From := SCO_Raw_Table.Last + 1; |
892125cd AC |
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; | |
6f12117a RD |
1132 | |
1133 | -- Traverse the unit | |
1134 | ||
37c1f923 | 1135 | Traverse_Aux_Decls (Cunit (U)); |
6f12117a | 1136 | |
37c1f923 | 1137 | case Nkind (Lu) is |
d8f43ee6 HK |
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 | => | |
7130729a | 1147 | Traverse_Declarations_Or_Statements (L => No_List, P => Lu); |
6f12117a | 1148 | |
d8f43ee6 HK |
1149 | -- All other cases of compilation units (e.g. renamings), generate no |
1150 | -- SCO information. | |
5ffe0bab | 1151 | |
d8f43ee6 | 1152 | when others => |
5ffe0bab AC |
1153 | null; |
1154 | end case; | |
892125cd | 1155 | |
240fe2a4 AC |
1156 | -- Make entry for new unit in unit tables, we will fill in the file |
1157 | -- name and dependency numbers later. | |
892125cd | 1158 | |
240fe2a4 | 1159 | SCO_Unit_Table.Append ( |
baa571ab AC |
1160 | (Dep_Num => 0, |
1161 | File_Name => null, | |
1162 | File_Index => Get_Source_File_Index (Sloc (Lu)), | |
1163 | From => From, | |
0566484a | 1164 | To => SCO_Raw_Table.Last)); |
240fe2a4 AC |
1165 | |
1166 | SCO_Unit_Number_Table.Append (U); | |
0566484a | 1167 | end SCO_Record_Raw; |
6f12117a RD |
1168 | |
1169 | ----------------------- | |
1170 | -- Set_SCO_Condition -- | |
1171 | ----------------------- | |
1172 | ||
25adc5fb | 1173 | procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is |
0566484a AC |
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 | ||
009c0268 AC |
1179 | Constant_Condition_Code : constant array (Boolean) of Character := |
1180 | (False => 'f', True => 't'); | |
1181 | ||
25adc5fb | 1182 | Orig : constant Node_Id := Original_Node (Cond); |
009c0268 | 1183 | Dummy : Source_Ptr; |
25adc5fb AC |
1184 | Index : Nat; |
1185 | Start : Source_Ptr; | |
25adc5fb | 1186 | |
6f12117a | 1187 | begin |
25adc5fb | 1188 | Sloc_Range (Orig, Start, Dummy); |
0566484a | 1189 | Index := SCO_Raw_Hash_Table.Get (Start); |
b26be063 | 1190 | |
150ac76e AC |
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. | |
25adc5fb | 1194 | |
150ac76e AC |
1195 | if Index = 0 then |
1196 | return; | |
1197 | ||
1198 | else | |
0566484a AC |
1199 | pragma Assert (SCO_Raw_Table.Table (Index).C1 = ' '); |
1200 | SCO_Raw_Table.Table (Index).C2 := Constant_Condition_Code (Val); | |
6f12117a RD |
1201 | end if; |
1202 | end Set_SCO_Condition; | |
1203 | ||
0566484a AC |
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 | ||
009c0268 | 1214 | Orig : constant Node_Id := Original_Node (Op); |
0566484a | 1215 | Orig_Sloc : constant Source_Ptr := Sloc (Orig); |
009c0268 | 1216 | Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc); |
0566484a AC |
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 | ||
b26be063 AC |
1228 | ---------------------------- |
1229 | -- Set_SCO_Pragma_Enabled -- | |
1230 | ---------------------------- | |
1231 | ||
1232 | procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is | |
0566484a AC |
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 | ||
b26be063 AC |
1238 | Index : Nat; |
1239 | ||
1240 | begin | |
150ac76e AC |
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 | |
dd2d73a7 | 1245 | and then In_Extended_Main_Source_Unit (Loc) |
150ac76e AC |
1246 | and then not (In_Instance or In_Inlined_Body)) |
1247 | then | |
1248 | return; | |
1249 | end if; | |
1250 | ||
b26be063 AC |
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 | ||
0566484a | 1255 | Index := SCO_Raw_Hash_Table.Get (Loc); |
b26be063 | 1256 | |
2c28c7a7 AC |
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. | |
b26be063 | 1263 | |
150ac76e | 1264 | if Index = 0 then |
2c28c7a7 | 1265 | return; |
150ac76e AC |
1266 | |
1267 | else | |
44a10091 | 1268 | declare |
0566484a | 1269 | T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index); |
dedac3eb | 1270 | |
44a10091 | 1271 | begin |
06ad40d3 AC |
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'; | |
44a10091 | 1281 | |
06ad40d3 AC |
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; | |
44a10091 | 1294 | end; |
b26be063 AC |
1295 | end if; |
1296 | end Set_SCO_Pragma_Enabled; | |
1297 | ||
0566484a AC |
1298 | ------------------------- |
1299 | -- Set_Raw_Table_Entry -- | |
1300 | ------------------------- | |
6f12117a | 1301 | |
0566484a | 1302 | procedure Set_Raw_Table_Entry |
06ad40d3 AC |
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) | |
6f12117a | 1310 | is |
0566484a | 1311 | pragma Assert (SCO_Generation_State = Raw); |
6f12117a | 1312 | begin |
0566484a | 1313 | SCO_Raw_Table.Append |
06ad40d3 AC |
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)); | |
0566484a | 1321 | end Set_Raw_Table_Entry; |
6f12117a | 1322 | |
cf427f02 AC |
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 | ||
6f12117a RD |
1338 | ----------------------------------------- |
1339 | -- Traverse_Declarations_Or_Statements -- | |
1340 | ----------------------------------------- | |
1341 | ||
25adc5fb AC |
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 | |
828d4cf0 | 1347 | N : Node_Id; |
25adc5fb AC |
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 | ||
009c0268 AC |
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. | |
25adc5fb AC |
1375 | |
1376 | type SD_Entry is record | |
1377 | Nod : Node_Id; | |
1378 | Lst : List_Id; | |
1379 | Typ : Character; | |
44a10091 | 1380 | Plo : Source_Ptr; |
25adc5fb AC |
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 | |
44a10091 AC |
1386 | -- argument (in which case Nod is set to Empty). Plo is the sloc of the |
1387 | -- enclosing pragma, if any. | |
25adc5fb | 1388 | |
009c0268 AC |
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"); | |
25adc5fb AC |
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 | ||
3128f955 AC |
1405 | procedure Traverse_Declarations_Or_Statements |
1406 | (L : List_Id; | |
727e7b1a AC |
1407 | D : Dominant_Info := No_Dominant; |
1408 | P : Node_Id := Empty) | |
dd2d73a7 AC |
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 | |
3128f955 AC |
1420 | is |
1421 | Current_Dominant : Dominant_Info := D; | |
1422 | -- Dominance information for the current basic block | |
1423 | ||
76264f60 AC |
1424 | Current_Test : Node_Id; |
1425 | -- Conditional node (N_If_Statement or N_Elsiif being processed | |
3128f955 | 1426 | |
727e7b1a | 1427 | N : Node_Id; |
6f12117a | 1428 | |
25adc5fb AC |
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 | |
9dbf1c3e RD |
1432 | |
1433 | procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); | |
9313a26a AC |
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. | |
9dbf1c3e | 1437 | |
25adc5fb AC |
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 | |
db318f46 | 1441 | -- the arguments are saved in the SD table for later processing when |
25adc5fb | 1442 | -- Set_Statement_Entry is called, which goes through the saved entries |
a77152ca AC |
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. | |
25adc5fb AC |
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 | ||
009c0268 AC |
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 | ||
727e7b1a AC |
1457 | procedure Traverse_One (N : Node_Id); |
1458 | -- Traverse one declaration or statement | |
1459 | ||
06ad40d3 AC |
1460 | procedure Traverse_Aspects (N : Node_Id); |
1461 | -- Helper for Traverse_One: traverse N's aspect specifications | |
1462 | ||
a77152ca | 1463 | procedure Traverse_Degenerate_Subprogram (N : Node_Id); |
9313a26a AC |
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. | |
a77152ca | 1466 | |
009c0268 AC |
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); | |
5efb89d0 AC |
1486 | else |
1487 | To_Node := Entry_Direct_Name (N); | |
009c0268 AC |
1488 | end if; |
1489 | ||
1490 | when N_Case_Statement => | |
1491 | To_Node := Expression (N); | |
1492 | ||
d8f43ee6 HK |
1493 | when N_Elsif_Part |
1494 | | N_If_Statement | |
1495 | => | |
009c0268 AC |
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 | ||
d8f43ee6 HK |
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 | => | |
009c0268 AC |
1511 | T := F; |
1512 | ||
d8f43ee6 HK |
1513 | when N_Protected_Type_Declaration |
1514 | | N_Task_Type_Declaration | |
1515 | => | |
009c0268 AC |
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 | ||
a77152ca AC |
1526 | when N_Subexpr => |
1527 | To_Node := N; | |
1528 | ||
009c0268 AC |
1529 | when others => |
1530 | null; | |
009c0268 AC |
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 | ||
6f12117a RD |
1554 | ------------------------- |
1555 | -- Set_Statement_Entry -- | |
1556 | ------------------------- | |
1557 | ||
1558 | procedure Set_Statement_Entry is | |
25adc5fb AC |
1559 | SC_Last : constant Int := SC.Last; |
1560 | SD_Last : constant Int := SD.Last; | |
9dbf1c3e | 1561 | |
6f12117a | 1562 | begin |
25adc5fb AC |
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 | |
3128f955 AC |
1567 | |
1568 | if Current_Dominant /= No_Dominant then | |
1569 | declare | |
009c0268 AC |
1570 | From : Source_Ptr; |
1571 | To : Source_Ptr; | |
1572 | ||
3128f955 AC |
1573 | begin |
1574 | Sloc_Range (Current_Dominant.N, From, To); | |
009c0268 | 1575 | |
3128f955 AC |
1576 | if Current_Dominant.K /= 'E' then |
1577 | To := No_Location; | |
1578 | end if; | |
009c0268 | 1579 | |
0566484a | 1580 | Set_Raw_Table_Entry |
06ad40d3 AC |
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); | |
3128f955 AC |
1588 | end; |
1589 | end if; | |
25adc5fb | 1590 | end if; |
9dbf1c3e | 1591 | |
25adc5fb | 1592 | declare |
06ad40d3 AC |
1593 | SCE : SC_Entry renames SC.Table (J); |
1594 | Pragma_Sloc : Source_Ptr := No_Location; | |
1595 | Pragma_Aspect_Name : Name_Id := No_Name; | |
009c0268 | 1596 | |
25adc5fb | 1597 | begin |
dedac3eb | 1598 | -- For the case of a statement SCO for a pragma controlled by |
9b20e59b | 1599 | -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and |
44a10091 AC |
1600 | -- those of any nested decision) is emitted only if the pragma |
1601 | -- is enabled. | |
8fb3f5df | 1602 | |
44a10091 | 1603 | if SCE.Typ = 'p' then |
8fb3f5df | 1604 | Pragma_Sloc := SCE.From; |
0566484a AC |
1605 | SCO_Raw_Hash_Table.Set |
1606 | (Pragma_Sloc, SCO_Raw_Table.Last + 1); | |
6e759c2a | 1607 | Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N); |
06ad40d3 | 1608 | pragma Assert (Pragma_Aspect_Name /= No_Name); |
828d4cf0 TQ |
1609 | |
1610 | elsif SCE.Typ = 'P' then | |
6e759c2a | 1611 | Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N); |
06ad40d3 | 1612 | pragma Assert (Pragma_Aspect_Name /= No_Name); |
8fb3f5df AC |
1613 | end if; |
1614 | ||
0566484a | 1615 | Set_Raw_Table_Entry |
06ad40d3 AC |
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); | |
25adc5fb AC |
1623 | end; |
1624 | end loop; | |
9dbf1c3e | 1625 | |
3128f955 AC |
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 | ||
25adc5fb AC |
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); | |
009c0268 | 1642 | |
25adc5fb AC |
1643 | begin |
1644 | if Present (SDE.Nod) then | |
44a10091 | 1645 | Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo); |
25adc5fb | 1646 | else |
44a10091 | 1647 | Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo); |
25adc5fb AC |
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); | |
6f12117a RD |
1655 | end Set_Statement_Entry; |
1656 | ||
06ad40d3 AC |
1657 | ---------------------- |
1658 | -- Traverse_Aspects -- | |
1659 | ---------------------- | |
1660 | ||
1661 | procedure Traverse_Aspects (N : Node_Id) is | |
06ad40d3 | 1662 | AE : Node_Id; |
009c0268 | 1663 | AN : Node_Id; |
1c66c4f5 | 1664 | C1 : Character; |
06ad40d3 AC |
1665 | |
1666 | begin | |
1667 | AN := First (Aspect_Specifications (N)); | |
1668 | while Present (AN) loop | |
1669 | AE := Expression (AN); | |
1670 | ||
1c66c4f5 AC |
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 | ||
9a7049fd | 1678 | case Get_Aspect_Id (AN) is |
06ad40d3 AC |
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 | |
62807842 AC |
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??? | |
06ad40d3 | 1692 | |
57f6e00c AC |
1693 | when Aspect_Dynamic_Predicate |
1694 | | Aspect_Invariant | |
d8f43ee6 HK |
1695 | | Aspect_Post |
1696 | | Aspect_Postcondition | |
1697 | | Aspect_Pre | |
1698 | | Aspect_Precondition | |
d8f43ee6 HK |
1699 | | Aspect_Predicate |
1700 | | Aspect_Static_Predicate | |
57f6e00c | 1701 | | Aspect_Type_Invariant |
d8f43ee6 | 1702 | => |
62807842 | 1703 | C1 := 'a'; |
06ad40d3 AC |
1704 | |
1705 | -- Other aspects: just process any decision nested in the | |
1706 | -- aspect expression. | |
1707 | ||
1708 | when others => | |
06ad40d3 | 1709 | if Has_Decision (AE) then |
1c66c4f5 | 1710 | C1 := 'X'; |
06ad40d3 | 1711 | end if; |
06ad40d3 AC |
1712 | end case; |
1713 | ||
1c66c4f5 AC |
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 | ||
06ad40d3 AC |
1726 | Next (AN); |
1727 | end loop; | |
1728 | end Traverse_Aspects; | |
1729 | ||
a77152ca AC |
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 | |
9313a26a AC |
1745 | -- Output statement SCO for degenerate subprogram body (null |
1746 | -- statement or freestanding expression) outside of the dominance | |
1747 | -- chain. | |
a77152ca AC |
1748 | |
1749 | Current_Dominant := No_Dominant; | |
b0f920c9 | 1750 | Extend_Statement_Sequence (N, Typ => 'X'); |
a77152ca AC |
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; | |
9313a26a | 1758 | |
a77152ca AC |
1759 | Set_Statement_Entry; |
1760 | ||
9313a26a AC |
1761 | -- Restore current dominant information designating last statement |
1762 | -- in previous sequence (i.e. make the dominance chain skip over | |
1763 | -- the degenerate body). | |
a77152ca AC |
1764 | |
1765 | Current_Dominant := Saved_Dominant; | |
1766 | end; | |
1767 | end Traverse_Degenerate_Subprogram; | |
1768 | ||
727e7b1a AC |
1769 | ------------------ |
1770 | -- Traverse_One -- | |
1771 | ------------------ | |
6f12117a | 1772 | |
727e7b1a AC |
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. | |
6f12117a | 1779 | |
727e7b1a | 1780 | case Nkind (N) is |
6f12117a | 1781 | |
727e7b1a | 1782 | -- Package declaration |
7ef50d41 | 1783 | |
727e7b1a AC |
1784 | when N_Package_Declaration => |
1785 | Set_Statement_Entry; | |
ef7c5fa9 | 1786 | Traverse_Package_Declaration (N, Current_Dominant); |
6f12117a | 1787 | |
727e7b1a | 1788 | -- Generic package declaration |
6f12117a | 1789 | |
727e7b1a AC |
1790 | when N_Generic_Package_Declaration => |
1791 | Set_Statement_Entry; | |
1792 | Traverse_Generic_Package_Declaration (N); | |
6f12117a | 1793 | |
727e7b1a | 1794 | -- Package body |
6f12117a | 1795 | |
727e7b1a AC |
1796 | when N_Package_Body => |
1797 | Set_Statement_Entry; | |
1798 | Traverse_Package_Body (N); | |
892125cd | 1799 | |
e19137bc | 1800 | -- Subprogram declaration or subprogram body stub |
892125cd | 1801 | |
9313a26a AC |
1802 | when N_Expression_Function |
1803 | | N_Subprogram_Body_Stub | |
d8f43ee6 HK |
1804 | | N_Subprogram_Declaration |
1805 | => | |
a77152ca AC |
1806 | declare |
1807 | Spec : constant Node_Id := Specification (N); | |
1808 | begin | |
1809 | Process_Decisions_Defer | |
1810 | (Parameter_Specifications (Spec), 'X'); | |
1811 | ||
b912db16 AC |
1812 | -- Case of a null procedure: generate SCO for fictitious |
1813 | -- NULL statement located at the NULL keyword in the | |
1814 | -- procedure specification. | |
a77152ca AC |
1815 | |
1816 | if Nkind (N) = N_Subprogram_Declaration | |
1817 | and then Nkind (Spec) = N_Procedure_Specification | |
1818 | and then Null_Present (Spec) | |
1819 | then | |
b912db16 | 1820 | Traverse_Degenerate_Subprogram (Null_Statement (Spec)); |
a77152ca | 1821 | |
9313a26a AC |
1822 | -- Case of an expression function: generate a statement SCO |
1823 | -- for the expression (and then decision SCOs for any nested | |
1824 | -- decisions). | |
a77152ca AC |
1825 | |
1826 | elsif Nkind (N) = N_Expression_Function then | |
1827 | Traverse_Degenerate_Subprogram (Expression (N)); | |
1828 | end if; | |
1829 | end; | |
6f12117a | 1830 | |
e19137bc AC |
1831 | -- Entry declaration |
1832 | ||
1833 | when N_Entry_Declaration => | |
1834 | Process_Decisions_Defer (Parameter_Specifications (N), 'X'); | |
1835 | ||
727e7b1a | 1836 | -- Generic subprogram declaration |
6f12117a | 1837 | |
727e7b1a AC |
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'); | |
892125cd | 1843 | |
727e7b1a | 1844 | -- Task or subprogram body |
892125cd | 1845 | |
d8f43ee6 HK |
1846 | when N_Subprogram_Body |
1847 | | N_Task_Body | |
1848 | => | |
727e7b1a AC |
1849 | Set_Statement_Entry; |
1850 | Traverse_Subprogram_Or_Task_Body (N); | |
892125cd | 1851 | |
727e7b1a | 1852 | -- Entry body |
892125cd | 1853 | |
727e7b1a AC |
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; | |
5ffe0bab | 1860 | |
727e7b1a | 1861 | begin |
5ffe0bab | 1862 | Set_Statement_Entry; |
5ffe0bab | 1863 | |
727e7b1a AC |
1864 | if Present (Cond) then |
1865 | Process_Decisions_Defer (Cond, 'G'); | |
5ffe0bab | 1866 | |
727e7b1a AC |
1867 | -- For an entry body with a barrier, the entry body |
1868 | -- is dominanted by a True evaluation of the barrier. | |
2c1b72d7 | 1869 | |
727e7b1a AC |
1870 | Inner_Dominant := ('T', N); |
1871 | end if; | |
76264f60 | 1872 | |
727e7b1a AC |
1873 | Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant); |
1874 | end; | |
76264f60 | 1875 | |
727e7b1a | 1876 | -- Protected body |
2c1b72d7 | 1877 | |
727e7b1a AC |
1878 | when N_Protected_Body => |
1879 | Set_Statement_Entry; | |
7130729a | 1880 | Traverse_Declarations_Or_Statements (Declarations (N)); |
5ffe0bab | 1881 | |
727e7b1a AC |
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. | |
6f12117a | 1886 | |
727e7b1a | 1887 | when N_Exit_Statement => |
e19137bc | 1888 | Extend_Statement_Sequence (N, 'E'); |
727e7b1a AC |
1889 | Process_Decisions_Defer (Condition (N), 'E'); |
1890 | Set_Statement_Entry; | |
6f12117a | 1891 | |
727e7b1a AC |
1892 | -- If condition is present, then following statement is |
1893 | -- only executed if the condition evaluates to False. | |
6f12117a | 1894 | |
727e7b1a AC |
1895 | if Present (Condition (N)) then |
1896 | Current_Dominant := ('F', N); | |
1897 | else | |
1898 | Current_Dominant := No_Dominant; | |
1899 | end if; | |
76264f60 | 1900 | |
727e7b1a AC |
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. | |
76264f60 | 1904 | |
727e7b1a AC |
1905 | when N_Label => |
1906 | Set_Statement_Entry; | |
1907 | Current_Dominant := No_Dominant; | |
6f12117a | 1908 | |
727e7b1a | 1909 | -- Block statement, which breaks the current statement sequence |
9cd33a66 | 1910 | |
727e7b1a AC |
1911 | when N_Block_Statement => |
1912 | Set_Statement_Entry; | |
dd2d73a7 AC |
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 | ||
727e7b1a AC |
1921 | Traverse_Handled_Statement_Sequence |
1922 | (N => Handled_Statement_Sequence (N), | |
1923 | D => Current_Dominant); | |
9cd33a66 | 1924 | |
727e7b1a AC |
1925 | -- If statement, which breaks the current statement sequence, |
1926 | -- but we include the condition in the current sequence. | |
6f12117a | 1927 | |
727e7b1a AC |
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; | |
6f12117a | 1933 | |
727e7b1a | 1934 | -- Now we traverse the statements in the THEN part |
6f12117a | 1935 | |
727e7b1a AC |
1936 | Traverse_Declarations_Or_Statements |
1937 | (L => Then_Statements (N), | |
1938 | D => ('T', N)); | |
25adc5fb | 1939 | |
727e7b1a | 1940 | -- Loop through ELSIF parts if present |
25adc5fb | 1941 | |
727e7b1a AC |
1942 | if Present (Elsif_Parts (N)) then |
1943 | declare | |
1944 | Saved_Dominant : constant Dominant_Info := | |
1945 | Current_Dominant; | |
6f12117a | 1946 | |
727e7b1a | 1947 | Elif : Node_Id := First (Elsif_Parts (N)); |
25adc5fb | 1948 | |
727e7b1a AC |
1949 | begin |
1950 | while Present (Elif) loop | |
25adc5fb | 1951 | |
727e7b1a AC |
1952 | -- An Elsif is executed only if the previous test |
1953 | -- got a FALSE outcome. | |
25adc5fb | 1954 | |
727e7b1a | 1955 | Current_Dominant := ('F', Current_Test); |
76264f60 | 1956 | |
727e7b1a | 1957 | -- Now update current test information |
76264f60 | 1958 | |
727e7b1a | 1959 | Current_Test := Elif; |
76264f60 | 1960 | |
727e7b1a AC |
1961 | -- We generate a statement sequence for the |
1962 | -- construct "ELSIF condition", so that we have | |
1963 | -- a statement for the resulting decisions. | |
76264f60 | 1964 | |
727e7b1a AC |
1965 | Extend_Statement_Sequence (Elif, 'I'); |
1966 | Process_Decisions_Defer (Condition (Elif), 'I'); | |
1967 | Set_Statement_Entry; | |
25adc5fb | 1968 | |
727e7b1a AC |
1969 | -- An ELSIF part is never guaranteed to have |
1970 | -- been executed, following statements are only | |
1971 | -- dominated by the initial IF statement. | |
25adc5fb | 1972 | |
727e7b1a | 1973 | Current_Dominant := Saved_Dominant; |
76264f60 | 1974 | |
727e7b1a | 1975 | -- Traverse the statements in the ELSIF |
76264f60 | 1976 | |
727e7b1a AC |
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; | |
25adc5fb | 1984 | |
727e7b1a | 1985 | -- Finally traverse the ELSE statements if present |
6f12117a | 1986 | |
727e7b1a AC |
1987 | Traverse_Declarations_Or_Statements |
1988 | (L => Else_Statements (N), | |
1989 | D => ('F', Current_Test)); | |
25adc5fb | 1990 | |
727e7b1a AC |
1991 | -- CASE statement, which breaks the current statement sequence, |
1992 | -- but we include the expression in the current sequence. | |
6f12117a | 1993 | |
727e7b1a AC |
1994 | when N_Case_Statement => |
1995 | Extend_Statement_Sequence (N, 'C'); | |
1996 | Process_Decisions_Defer (Expression (N), 'X'); | |
1997 | Set_Statement_Entry; | |
82c7a5b1 | 1998 | |
727e7b1a AC |
1999 | -- Process case branches, all of which are dominated by the |
2000 | -- CASE statement. | |
82c7a5b1 | 2001 | |
727e7b1a AC |
2002 | declare |
2003 | Alt : Node_Id; | |
2004 | begin | |
009c0268 | 2005 | Alt := First_Non_Pragma (Alternatives (N)); |
727e7b1a AC |
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; | |
82c7a5b1 | 2013 | |
727e7b1a | 2014 | -- ACCEPT statement |
82c7a5b1 | 2015 | |
727e7b1a AC |
2016 | when N_Accept_Statement => |
2017 | Extend_Statement_Sequence (N, 'A'); | |
2018 | Set_Statement_Entry; | |
6f12117a | 2019 | |
727e7b1a AC |
2020 | -- Process sequence of statements, dominant is the ACCEPT |
2021 | -- statement. | |
6f12117a | 2022 | |
727e7b1a AC |
2023 | Traverse_Handled_Statement_Sequence |
2024 | (N => Handled_Statement_Sequence (N), | |
2025 | D => Current_Dominant); | |
6f12117a | 2026 | |
727e7b1a | 2027 | -- SELECT |
6f12117a | 2028 | |
727e7b1a AC |
2029 | when N_Selective_Accept => |
2030 | Extend_Statement_Sequence (N, 'S'); | |
2031 | Set_Statement_Entry; | |
6f12117a | 2032 | |
727e7b1a | 2033 | -- Process alternatives |
9dbf1c3e | 2034 | |
727e7b1a AC |
2035 | declare |
2036 | Alt : Node_Id; | |
2037 | Guard : Node_Id; | |
2038 | S_Dom : Dominant_Info; | |
3128f955 | 2039 | |
727e7b1a AC |
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; | |
6f12117a | 2053 | |
727e7b1a | 2054 | Traverse_One (Alt); |
6f12117a | 2055 | |
727e7b1a AC |
2056 | Current_Dominant := S_Dom; |
2057 | Next (Alt); | |
2058 | end loop; | |
2059 | end; | |
9c25bb25 | 2060 | |
727e7b1a AC |
2061 | Traverse_Declarations_Or_Statements |
2062 | (L => Else_Statements (N), | |
2063 | D => Current_Dominant); | |
e0f66eea | 2064 | |
d8f43ee6 HK |
2065 | when N_Conditional_Entry_Call |
2066 | | N_Timed_Entry_Call | |
2067 | => | |
727e7b1a AC |
2068 | Extend_Statement_Sequence (N, 'S'); |
2069 | Set_Statement_Entry; | |
ec80da28 | 2070 | |
727e7b1a | 2071 | -- Process alternatives |
ec80da28 | 2072 | |
727e7b1a | 2073 | Traverse_One (Entry_Call_Alternative (N)); |
e0f66eea | 2074 | |
727e7b1a AC |
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; | |
3128f955 | 2082 | |
727e7b1a AC |
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 => | |
5eeeed5e AC |
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 | ||
727e7b1a AC |
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 | ||
d8f43ee6 HK |
2129 | when N_Goto_Statement |
2130 | | N_Raise_Statement | |
2131 | | N_Requeue_Statement | |
2132 | => | |
727e7b1a AC |
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'); | |
009c0268 | 2150 | Process_Decisions_Defer (Return_Object_Declarations (N), 'X'); |
727e7b1a AC |
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; | |
3128f955 | 2168 | |
727e7b1a AC |
2169 | begin |
2170 | if Present (ISC) then | |
e0f66eea | 2171 | |
727e7b1a AC |
2172 | -- If iteration scheme present, extend the current |
2173 | -- statement sequence to include the iteration scheme | |
2174 | -- and process any decisions it contains. | |
6f12117a | 2175 | |
727e7b1a | 2176 | -- While loop |
3128f955 | 2177 | |
727e7b1a AC |
2178 | if Present (Condition (ISC)) then |
2179 | Extend_Statement_Sequence (N, 'W'); | |
2180 | Process_Decisions_Defer (Condition (ISC), 'W'); | |
3128f955 | 2181 | |
727e7b1a AC |
2182 | -- Set more specific dominant for inner statements |
2183 | -- (the control sloc for the decision is that of | |
2184 | -- the WHILE token). | |
6f12117a | 2185 | |
727e7b1a | 2186 | Inner_Dominant := ('T', ISC); |
65564d08 | 2187 | |
727e7b1a | 2188 | -- For loop |
44a10091 | 2189 | |
727e7b1a AC |
2190 | else |
2191 | Extend_Statement_Sequence (N, 'F'); | |
2192 | Process_Decisions_Defer | |
2193 | (Loop_Parameter_Specification (ISC), 'X'); | |
2194 | end if; | |
2195 | end if; | |
44a10091 | 2196 | |
727e7b1a | 2197 | Set_Statement_Entry; |
65564d08 | 2198 | |
727e7b1a AC |
2199 | if Inner_Dominant = No_Dominant then |
2200 | Inner_Dominant := Current_Dominant; | |
2201 | end if; | |
65564d08 | 2202 | |
727e7b1a AC |
2203 | Traverse_Declarations_Or_Statements |
2204 | (L => Statements (N), | |
2205 | D => Inner_Dominant); | |
2206 | end; | |
44a10091 | 2207 | |
727e7b1a | 2208 | -- Pragma |
65564d08 | 2209 | |
727e7b1a | 2210 | when N_Pragma => |
65564d08 | 2211 | |
727e7b1a | 2212 | -- Record sloc of pragma (pragmas don't nest) |
25adc5fb | 2213 | |
727e7b1a AC |
2214 | pragma Assert (Current_Pragma_Sloc = No_Location); |
2215 | Current_Pragma_Sloc := Sloc (N); | |
44a10091 | 2216 | |
727e7b1a | 2217 | -- Processing depends on the kind of pragma |
44a10091 | 2218 | |
727e7b1a | 2219 | declare |
6e759c2a | 2220 | Nam : constant Name_Id := Pragma_Name_Unmapped (N); |
727e7b1a AC |
2221 | Arg : Node_Id := |
2222 | First (Pragma_Argument_Associations (N)); | |
2223 | Typ : Character; | |
44a10091 | 2224 | |
727e7b1a AC |
2225 | begin |
2226 | case Nam is | |
d8f43ee6 HK |
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 | => | |
727e7b1a AC |
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; | |
44a10091 | 2245 | |
727e7b1a AC |
2246 | Process_Decisions_Defer (Expression (Arg), 'P'); |
2247 | Typ := 'p'; | |
44a10091 | 2248 | |
dd2d73a7 AC |
2249 | -- Pre/postconditions can be inherited so SCO should |
2250 | -- never be deactivated??? | |
2251 | ||
727e7b1a AC |
2252 | when Name_Debug => |
2253 | if Present (Arg) and then Present (Next (Arg)) then | |
44a10091 | 2254 | |
727e7b1a AC |
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. | |
44a10091 | 2258 | |
727e7b1a AC |
2259 | Process_Decisions_Defer (Expression (Arg), 'P'); |
2260 | Next (Arg); | |
2261 | end if; | |
25adc5fb | 2262 | |
727e7b1a AC |
2263 | Process_Decisions_Defer (Expression (Arg), 'X'); |
2264 | Typ := 'p'; | |
25adc5fb | 2265 | |
727e7b1a AC |
2266 | -- For all other pragmas, we generate decision entries |
2267 | -- for any embedded expressions, and the pragma is | |
2268 | -- never disabled. | |
25adc5fb | 2269 | |
dd2d73a7 AC |
2270 | -- Should generate P decisions (not X) for assertion |
2271 | -- related pragmas: [Type_]Invariant, | |
2272 | -- [{Static,Dynamic}_]Predicate??? | |
2273 | ||
727e7b1a | 2274 | when others => |
25adc5fb | 2275 | Process_Decisions_Defer (N, 'X'); |
727e7b1a AC |
2276 | Typ := 'P'; |
2277 | end case; | |
65564d08 | 2278 | |
727e7b1a | 2279 | -- Add statement SCO |
6f12117a | 2280 | |
727e7b1a | 2281 | Extend_Statement_Sequence (N, Typ); |
9dbf1c3e | 2282 | |
727e7b1a AC |
2283 | Current_Pragma_Sloc := No_Location; |
2284 | end; | |
9dbf1c3e | 2285 | |
727e7b1a AC |
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 | |
db318f46 | 2289 | -- want one entry in the SCOs, so we take the first, for which |
727e7b1a | 2290 | -- Prev_Ids is False. |
9dbf1c3e | 2291 | |
d8f43ee6 HK |
2292 | when N_Number_Declaration |
2293 | | N_Object_Declaration | |
2294 | => | |
727e7b1a AC |
2295 | if not Prev_Ids (N) then |
2296 | Extend_Statement_Sequence (N, 'o'); | |
9dbf1c3e | 2297 | |
727e7b1a AC |
2298 | if Has_Decision (N) then |
2299 | Process_Decisions_Defer (N, 'X'); | |
2300 | end if; | |
2301 | end if; | |
9dbf1c3e | 2302 | |
727e7b1a AC |
2303 | -- All other cases, which extend the current statement sequence |
2304 | -- but do not terminate it, even if they have nested decisions. | |
9dbf1c3e | 2305 | |
d8f43ee6 HK |
2306 | when N_Protected_Type_Declaration |
2307 | | N_Task_Type_Declaration | |
2308 | => | |
db318f46 AC |
2309 | Extend_Statement_Sequence (N, 't'); |
2310 | Process_Decisions_Defer (Discriminant_Specifications (N), 'X'); | |
2311 | Set_Statement_Entry; | |
2312 | ||
7130729a | 2313 | Traverse_Sync_Definition (N); |
db318f46 | 2314 | |
d8f43ee6 HK |
2315 | when N_Single_Protected_Declaration |
2316 | | N_Single_Task_Declaration | |
2317 | => | |
db318f46 AC |
2318 | Extend_Statement_Sequence (N, 'o'); |
2319 | Set_Statement_Entry; | |
2320 | ||
7130729a | 2321 | Traverse_Sync_Definition (N); |
db318f46 | 2322 | |
727e7b1a | 2323 | when others => |
9dbf1c3e | 2324 | |
727e7b1a AC |
2325 | -- Determine required type character code, or ASCII.NUL if |
2326 | -- no SCO should be generated for this node. | |
7c62a85a | 2327 | |
727e7b1a | 2328 | declare |
e19137bc | 2329 | NK : constant Node_Kind := Nkind (N); |
727e7b1a | 2330 | Typ : Character; |
9dbf1c3e | 2331 | |
727e7b1a | 2332 | begin |
e19137bc | 2333 | case NK is |
d8f43ee6 HK |
2334 | when N_Full_Type_Declaration |
2335 | | N_Incomplete_Type_Declaration | |
2336 | | N_Private_Extension_Declaration | |
2337 | | N_Private_Type_Declaration | |
2338 | => | |
727e7b1a | 2339 | Typ := 't'; |
9dbf1c3e | 2340 | |
d8f43ee6 | 2341 | when N_Subtype_Declaration => |
727e7b1a | 2342 | Typ := 's'; |
7ef50d41 | 2343 | |
d8f43ee6 | 2344 | when N_Renaming_Declaration => |
727e7b1a AC |
2345 | Typ := 'r'; |
2346 | ||
d8f43ee6 | 2347 | when N_Generic_Instantiation => |
727e7b1a AC |
2348 | Typ := 'i'; |
2349 | ||
d8f43ee6 HK |
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 | => | |
727e7b1a AC |
2357 | Typ := ASCII.NUL; |
2358 | ||
e19137bc | 2359 | when N_Procedure_Call_Statement => |
727e7b1a | 2360 | Typ := ' '; |
e19137bc | 2361 | |
d8f43ee6 | 2362 | when others => |
e19137bc AC |
2363 | if NK in N_Statement_Other_Than_Procedure_Call then |
2364 | Typ := ' '; | |
2365 | else | |
2366 | Typ := 'd'; | |
2367 | end if; | |
727e7b1a AC |
2368 | end case; |
2369 | ||
2370 | if Typ /= ASCII.NUL then | |
2371 | Extend_Statement_Sequence (N, Typ); | |
6f12117a | 2372 | end if; |
727e7b1a AC |
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 | ||
06ad40d3 AC |
2382 | -- Process aspects if present |
2383 | ||
2384 | Traverse_Aspects (N); | |
727e7b1a AC |
2385 | end Traverse_One; |
2386 | ||
2387 | -- Start of processing for Traverse_Declarations_Or_Statements | |
2388 | ||
2389 | begin | |
37c1f923 AC |
2390 | -- Process single prefixed node |
2391 | ||
727e7b1a AC |
2392 | if Present (P) then |
2393 | Traverse_One (P); | |
2394 | end if; | |
2395 | ||
37c1f923 | 2396 | -- Loop through statements or declarations |
6f12117a | 2397 | |
37c1f923 | 2398 | if Is_Non_Empty_List (L) then |
727e7b1a AC |
2399 | N := First (L); |
2400 | while Present (N) loop | |
fd3fa68f AC |
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; | |
bbf1aec2 | 2408 | |
6f12117a RD |
2409 | Next (N); |
2410 | end loop; | |
2411 | ||
6f12117a | 2412 | end if; |
25adc5fb | 2413 | |
37c1f923 | 2414 | -- End sequence of statements and flush deferred decisions |
25adc5fb | 2415 | |
37c1f923 AC |
2416 | if Present (P) or else Is_Non_Empty_List (L) then |
2417 | Set_Statement_Entry; | |
2418 | end if; | |
dd2d73a7 AC |
2419 | |
2420 | return Current_Dominant; | |
37c1f923 | 2421 | end Traverse_Declarations_Or_Statements; |
25adc5fb | 2422 | |
892125cd AC |
2423 | ------------------------------------------ |
2424 | -- Traverse_Generic_Package_Declaration -- | |
2425 | ------------------------------------------ | |
2426 | ||
2427 | procedure Traverse_Generic_Package_Declaration (N : Node_Id) is | |
2428 | begin | |
44a10091 | 2429 | Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location); |
892125cd AC |
2430 | Traverse_Package_Declaration (N); |
2431 | end Traverse_Generic_Package_Declaration; | |
2432 | ||
6f12117a RD |
2433 | ----------------------------------------- |
2434 | -- Traverse_Handled_Statement_Sequence -- | |
2435 | ----------------------------------------- | |
2436 | ||
3128f955 AC |
2437 | procedure Traverse_Handled_Statement_Sequence |
2438 | (N : Node_Id; | |
2439 | D : Dominant_Info := No_Dominant) | |
2440 | is | |
6f12117a RD |
2441 | Handler : Node_Id; |
2442 | ||
2443 | begin | |
9d607bc3 AC |
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. | |
96867674 | 2447 | |
9d607bc3 | 2448 | if Present (N) and then Comes_From_Source (N) then |
3128f955 | 2449 | Traverse_Declarations_Or_Statements (Statements (N), D); |
6f12117a RD |
2450 | |
2451 | if Present (Exception_Handlers (N)) then | |
009c0268 | 2452 | Handler := First_Non_Pragma (Exception_Handlers (N)); |
6f12117a | 2453 | while Present (Handler) loop |
3128f955 AC |
2454 | Traverse_Declarations_Or_Statements |
2455 | (L => Statements (Handler), | |
2456 | D => ('E', Handler)); | |
6f12117a RD |
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 | |
dd2d73a7 | 2468 | Dom : Dominant_Info; |
6f12117a | 2469 | begin |
dd2d73a7 AC |
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); | |
6f12117a RD |
2477 | end Traverse_Package_Body; |
2478 | ||
2479 | ---------------------------------- | |
2480 | -- Traverse_Package_Declaration -- | |
2481 | ---------------------------------- | |
2482 | ||
ef7c5fa9 AC |
2483 | procedure Traverse_Package_Declaration |
2484 | (N : Node_Id; | |
2485 | D : Dominant_Info := No_Dominant) | |
2486 | is | |
6f12117a | 2487 | Spec : constant Node_Id := Specification (N); |
dd2d73a7 | 2488 | Dom : Dominant_Info; |
4ff4293f | 2489 | |
6f12117a | 2490 | begin |
4ff4293f AC |
2491 | Dom := |
2492 | Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D); | |
ef7c5fa9 | 2493 | |
4ff4293f | 2494 | -- First private declaration is dominated by last visible declaration |
dd2d73a7 | 2495 | |
dd2d73a7 | 2496 | Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom); |
6f12117a RD |
2497 | end Traverse_Package_Declaration; |
2498 | ||
7130729a TQ |
2499 | ------------------------------ |
2500 | -- Traverse_Sync_Definition -- | |
2501 | ------------------------------ | |
5ffe0bab | 2502 | |
7130729a TQ |
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. | |
5ffe0bab | 2507 | |
7130729a TQ |
2508 | Sync_Def : Node_Id; |
2509 | -- N's protected or task definition | |
db318f46 | 2510 | |
009c0268 AC |
2511 | Priv_Decl : List_Id; |
2512 | Vis_Decl : List_Id; | |
27b95a65 | 2513 | -- Sync_Def's Visible_Declarations and Private_Declarations |
db318f46 AC |
2514 | |
2515 | begin | |
7130729a | 2516 | case Nkind (N) is |
d8f43ee6 HK |
2517 | when N_Protected_Type_Declaration |
2518 | | N_Single_Protected_Declaration | |
2519 | => | |
7130729a TQ |
2520 | Sync_Def := Protected_Definition (N); |
2521 | ||
d8f43ee6 HK |
2522 | when N_Single_Task_Declaration |
2523 | | N_Task_Type_Declaration | |
2524 | => | |
7130729a TQ |
2525 | Sync_Def := Task_Definition (N); |
2526 | ||
2527 | when others => | |
2528 | raise Program_Error; | |
2529 | end case; | |
2530 | ||
27b95a65 OH |
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 | |
009c0268 | 2535 | Vis_Decl := Visible_Declarations (Sync_Def); |
27b95a65 OH |
2536 | Priv_Decl := Private_Declarations (Sync_Def); |
2537 | else | |
009c0268 | 2538 | Vis_Decl := No_List; |
27b95a65 OH |
2539 | Priv_Decl := No_List; |
2540 | end if; | |
7130729a | 2541 | |
dd2d73a7 AC |
2542 | Dom_Info := Traverse_Declarations_Or_Statements |
2543 | (L => Vis_Decl, | |
2544 | D => Dom_Info); | |
db318f46 | 2545 | |
7130729a TQ |
2546 | -- If visible declarations are present, the first private declaration |
2547 | -- is dominated by the last visible declaration. | |
2548 | ||
db318f46 | 2549 | Traverse_Declarations_Or_Statements |
27b95a65 | 2550 | (L => Priv_Decl, |
db318f46 | 2551 | D => Dom_Info); |
7130729a | 2552 | end Traverse_Sync_Definition; |
db318f46 | 2553 | |
5ffe0bab AC |
2554 | -------------------------------------- |
2555 | -- Traverse_Subprogram_Or_Task_Body -- | |
2556 | -------------------------------------- | |
6f12117a | 2557 | |
76264f60 AC |
2558 | procedure Traverse_Subprogram_Or_Task_Body |
2559 | (N : Node_Id; | |
2560 | D : Dominant_Info := No_Dominant) | |
2561 | is | |
dd2d73a7 | 2562 | Decls : constant List_Id := Declarations (N); |
009c0268 AC |
2563 | Dom_Info : Dominant_Info := D; |
2564 | ||
6f12117a | 2565 | begin |
dd2d73a7 AC |
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); | |
5ffe0bab | 2575 | end Traverse_Subprogram_Or_Task_Body; |
6f12117a | 2576 | |
0566484a AC |
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 | ||
009c0268 AC |
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. | |
0566484a AC |
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 | ||
009c0268 AC |
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. | |
0566484a AC |
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 | ||
009c0268 AC |
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. | |
0566484a | 2636 | |
009c0268 AC |
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. | |
0566484a | 2644 | |
009c0268 AC |
2645 | ------------------------- |
2646 | -- Add_Expression_Tree -- | |
2647 | ------------------------- | |
0566484a | 2648 | |
009c0268 AC |
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; | |
0566484a | 2654 | |
0566484a | 2655 | begin |
009c0268 AC |
2656 | case T.C1 is |
2657 | when ' ' => | |
0566484a | 2658 | |
009c0268 | 2659 | -- This is a single condition. Add an entry for it and move on |
0566484a | 2660 | |
009c0268 AC |
2661 | SCO_Table.Append (T); |
2662 | Idx := Idx + 1; | |
0566484a | 2663 | |
009c0268 | 2664 | when '!' => |
0566484a | 2665 | |
009c0268 AC |
2666 | -- This is a NOT operator: add an entry for it and browse its |
2667 | -- only child. | |
0566484a | 2668 | |
009c0268 | 2669 | SCO_Table.Append (T); |
0566484a | 2670 | Idx := Idx + 1; |
009c0268 | 2671 | Add_Expression_Tree (Idx); |
0566484a | 2672 | |
009c0268 | 2673 | when others => |
0566484a | 2674 | |
009c0268 | 2675 | -- This must be an AND/OR/AND THEN/OR ELSE operator |
0566484a | 2676 | |
009c0268 | 2677 | if T.C2 = '?' then |
0566484a | 2678 | |
009c0268 AC |
2679 | -- This is not a short circuit operator: consider this one |
2680 | -- and all its children as a single condition. | |
0566484a | 2681 | |
009c0268 AC |
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)); | |
0566484a | 2691 | |
009c0268 AC |
2692 | else |
2693 | -- This is a real short circuit operator: add an entry for | |
2694 | -- it and browse its children. | |
0566484a | 2695 | |
009c0268 AC |
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; | |
0566484a AC |
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; | |
009c0268 | 2713 | |
0566484a AC |
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 | |
009c0268 AC |
2732 | Sloc_F : Source_Location := No_Source_Location; |
2733 | Sloc_T : Source_Location := No_Source_Location; | |
0566484a AC |
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; | |
009c0268 | 2751 | |
0566484a AC |
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; | |
009c0268 | 2788 | To := Sloc_T; |
0566484a AC |
2789 | end Compute_Range; |
2790 | ||
009c0268 AC |
2791 | ----------------- |
2792 | -- Is_Decision -- | |
2793 | ----------------- | |
0566484a | 2794 | |
009c0268 AC |
2795 | function Is_Decision (Idx : Nat) return Boolean is |
2796 | Index : Nat := Idx; | |
0566484a AC |
2797 | |
2798 | begin | |
009c0268 AC |
2799 | loop |
2800 | declare | |
2801 | T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index); | |
0566484a | 2802 | |
009c0268 AC |
2803 | begin |
2804 | case T.C1 is | |
2805 | when ' ' => | |
2806 | return False; | |
0566484a | 2807 | |
009c0268 | 2808 | when '!' => |
0566484a | 2809 | |
009c0268 AC |
2810 | -- This is a decision iff the only operand of the NOT |
2811 | -- operator could be a standalone decision. | |
0566484a | 2812 | |
009c0268 | 2813 | Index := Idx + 1; |
0566484a | 2814 | |
009c0268 | 2815 | when others => |
0566484a | 2816 | |
009c0268 AC |
2817 | -- This node is a logical operator (and thus could be a |
2818 | -- standalone decision) iff it is a short circuit | |
2819 | -- operator. | |
0566484a | 2820 | |
009c0268 | 2821 | return T.C2 /= '?'; |
009c0268 AC |
2822 | end case; |
2823 | end; | |
2824 | end loop; | |
2825 | end Is_Decision; | |
0566484a AC |
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 | ||
009c0268 AC |
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 | ||
93e90bf4 | 2894 | -- This is not a logical operator: start looking for |
009c0268 AC |
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 | ||
93e90bf4 | 2946 | -- This is not a logical operator: start looking for |
009c0268 AC |
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 | ||
0566484a AC |
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 | |
009c0268 | 2982 | renames SCO_Unit_Table.Table (Unit_Idx); |
0566484a AC |
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; | |
009c0268 | 3042 | Unit.To := SCO_Table.Last; |
0566484a AC |
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 | ||
6f12117a | 3051 | end Par_SCO; |