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