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