PR lto/83954
[official-gcc.git] / gcc / ada / par_sco.adb
blob1a337291bcb94a30ba7a01dcf1d816f2814448ca
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-2018, 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 ------------------------------------------------------------------------------
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;
45 with GNAT.HTable; use GNAT.HTable;
46 with GNAT.Heap_Sort_G;
48 package body Par_SCO is
50 --------------------------
51 -- First-pass SCO table --
52 --------------------------
54 -- The Short_Circuit_And_Or pragma enables one to use AND and OR operators
55 -- in source code while the ones used with booleans will be interpreted as
56 -- their short circuit alternatives (AND THEN and OR ELSE). Thus, the true
57 -- meaning of these operators is known only after the semantic analysis.
59 -- However, decision SCOs include short circuit operators only. The SCO
60 -- information generation pass must be done before expansion, hence before
61 -- the semantic analysis. Because of this, the SCO information generation
62 -- is done in two passes.
64 -- The first one (SCO_Record_Raw, before semantic analysis) completes the
65 -- SCO_Raw_Table assuming all AND/OR operators are short circuit ones.
66 -- Then, the semantic analysis determines which operators are promoted to
67 -- short circuit ones. Finally, the second pass (SCO_Record_Filtered)
68 -- translates the SCO_Raw_Table to SCO_Table, taking care of removing the
69 -- remaining AND/OR operators and of adjusting decisions accordingly
70 -- (splitting decisions, removing empty ones, etc.).
72 type SCO_Generation_State_Type is (None, Raw, Filtered);
73 SCO_Generation_State : SCO_Generation_State_Type := None;
74 -- Keep track of the SCO generation state: this will prevent us from
75 -- running some steps multiple times (the second pass has to be started
76 -- from multiple places).
78 package SCO_Raw_Table is new Table.Table
79 (Table_Component_Type => SCO_Table_Entry,
80 Table_Index_Type => Nat,
81 Table_Low_Bound => 1,
82 Table_Initial => 500,
83 Table_Increment => 300,
84 Table_Name => "Raw_Table");
86 -----------------------
87 -- Unit Number Table --
88 -----------------------
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.
95 -- Note that the zero'th entry is here for convenience in sorting the
96 -- table, the real lower bound is 1.
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");
106 ------------------------------------------
107 -- Condition/Operator/Pragma Hash Table --
108 ------------------------------------------
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.
117 type Header_Num is new Integer range 0 .. 996;
118 -- Type for hash table headers
120 function Hash (F : Source_Ptr) return Header_Num;
121 -- Function to Hash source pointer value
123 function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean;
124 -- Function to test two keys for equality
126 function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean;
127 -- Function to test for source locations order
129 package SCO_Raw_Hash_Table is new Simple_HTable
130 (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
131 -- The actual hash table
133 --------------------------
134 -- Internal Subprograms --
135 --------------------------
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).
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.
147 type Tristate is (False, True, Unknown);
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.
156 function To_Source_Location (S : Source_Ptr) return Source_Location;
157 -- Converts Source_Ptr value to Source_Location (line/col) format
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).
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
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
186 type Dominant_Info is record
187 K : Character;
188 -- F/T/S/E for a valid dominance marker, or ' ' for no dominant
190 N : Node_Id;
191 -- Node providing the Sloc(s) for the dominance marker
192 end record;
193 No_Dominant : constant Dominant_Info := (' ', Empty);
195 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr);
196 -- Add one entry from the instance table to the corresponding SCO table
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.
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.
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.
217 -- Why is Traverse_Sync_Definition commented specifically, whereas
218 -- the others are not???
220 procedure Traverse_Generic_Package_Declaration (N : Node_Id);
222 procedure Traverse_Handled_Statement_Sequence
223 (N : Node_Id;
224 D : Dominant_Info := No_Dominant);
226 procedure Traverse_Package_Body (N : Node_Id);
228 procedure Traverse_Package_Declaration
229 (N : Node_Id;
230 D : Dominant_Info := No_Dominant);
232 procedure Traverse_Subprogram_Or_Task_Body
233 (N : Node_Id;
234 D : Dominant_Info := No_Dominant);
236 procedure Traverse_Sync_Definition (N : Node_Id);
237 -- Traverse a protected definition or task definition
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.
246 procedure Write_SCOs_To_ALI_File is new Put_SCOs;
247 -- Write SCO information to the ALI file using routines in Lib.Util
249 ----------
250 -- dsco --
251 ----------
253 procedure dsco is
254 procedure Dump_Entry (Index : Nat; T : SCO_Table_Entry);
255 -- Dump a SCO table entry
257 ----------------
258 -- Dump_Entry --
259 ----------------
261 procedure Dump_Entry (Index : Nat; T : SCO_Table_Entry) is
262 begin
263 Write_Str (" ");
264 Write_Int (Index);
265 Write_Char ('.');
267 if T.C1 /= ' ' then
268 Write_Str (" C1 = '");
269 Write_Char (T.C1);
270 Write_Char (''');
271 end if;
273 if T.C2 /= ' ' then
274 Write_Str (" C2 = '");
275 Write_Char (T.C2);
276 Write_Char (''');
277 end if;
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;
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;
293 if T.Last then
294 Write_Str (" True");
295 else
296 Write_Str (" False");
297 end if;
299 Write_Eol;
300 end Dump_Entry;
302 -- Start of processing for dsco
304 begin
305 -- Dump SCO unit table
307 Write_Line ("SCO Unit Table");
308 Write_Line ("--------------");
310 for Index in 1 .. SCO_Unit_Table.Last loop
311 declare
312 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
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));
324 Write_Str (" File_Name = """);
326 if UTE.File_Name /= null then
327 Write_Str (UTE.File_Name.all);
328 end if;
330 Write_Char ('"');
331 Write_Eol;
332 end;
333 end loop;
335 -- Dump SCO Unit number table if it contains any entries
337 if SCO_Unit_Number_Table.Last >= 1 then
338 Write_Eol;
339 Write_Line ("SCO Unit Number Table");
340 Write_Line ("---------------------");
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;
351 -- Dump SCO raw-table
353 Write_Eol;
354 Write_Line ("SCO Raw Table");
355 Write_Line ("---------");
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;
365 -- Dump SCO table itself
367 Write_Eol;
368 Write_Line ("SCO Filtered Table");
369 Write_Line ("---------");
371 for Index in 1 .. SCO_Table.Last loop
372 Dump_Entry (Index, SCO_Table.Table (Index));
373 end loop;
374 end dsco;
376 -----------
377 -- Equal --
378 -----------
380 function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean is
381 begin
382 return F1 = F2;
383 end Equal;
385 -------
386 -- < --
387 -------
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 "<";
395 ------------------
396 -- Has_Decision --
397 ------------------
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).
405 ----------------
406 -- Check_Node --
407 ----------------
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.
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;
425 function Traverse is new Traverse_Func (Check_Node);
427 -- Start of processing for Has_Decision
429 begin
430 return Traverse (N) = Abandon;
431 end Has_Decision;
433 ----------
434 -- Hash --
435 ----------
437 function Hash (F : Source_Ptr) return Header_Num is
438 begin
439 return Header_Num (Nat (F) mod 997);
440 end Hash;
442 ----------------
443 -- Initialize --
444 ----------------
446 procedure Initialize is
447 begin
448 SCO_Unit_Number_Table.Init;
450 -- The SCO_Unit_Number_Table entry with index 0 is intentionally set
451 -- aside to be used as temporary for sorting.
453 SCO_Unit_Number_Table.Increment_Last;
454 end Initialize;
456 -------------------------
457 -- Is_Logical_Operator --
458 -------------------------
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;
471 -----------------------
472 -- Process_Decisions --
473 -----------------------
475 -- Version taking a list
477 procedure Process_Decisions
478 (L : List_Id;
479 T : Character;
480 Pragma_Sloc : Source_Ptr)
482 N : Node_Id;
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;
494 -- Version taking a node
496 Current_Pragma_Sloc : Source_Ptr := No_Location;
497 -- While processing a pragma, this is set to the sloc of the N_Pragma node
499 procedure Process_Decisions
500 (N : Node_Id;
501 T : Character;
502 Pragma_Sloc : Source_Ptr)
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.
509 Mark_Hash : Nat;
510 -- Likewise for the putative SCO_Raw_Hash_Table entries: see below
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.
522 -- This data structure holds the conditions/pragmas to register in
523 -- SCO_Raw_Hash_Table.
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.
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.
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.
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.
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.
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.
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.
570 -----------------------------
571 -- Output_Decision_Operand --
572 -----------------------------
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.
582 L : Node_Id;
583 T : Tristate;
585 begin
586 if No (N) then
587 return;
588 end if;
590 T := Is_Logical_Operator (N);
592 -- Logical operator
594 if T /= False then
595 if Nkind (N) = N_Op_Not then
596 C1 := '!';
597 L := Empty;
599 else
600 L := Left_Opnd (N);
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;
609 if T = True then
610 C2 := ' ';
611 else
612 C2 := '?';
613 end if;
615 Set_Raw_Table_Entry
616 (C1 => C1,
617 C2 => C2,
618 From => Sloc (N),
619 To => No_Location,
620 Last => False);
622 Hash_Entries.Append ((Sloc (N), SCO_Raw_Table.Last));
624 Output_Decision_Operand (L);
625 Output_Decision_Operand (Right_Opnd (N));
627 -- Not a logical operator
629 else
630 Output_Element (N);
631 end if;
632 end Output_Decision_Operand;
634 --------------------
635 -- Output_Element --
636 --------------------
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;
652 -------------------
653 -- Output_Header --
654 -------------------
656 procedure Output_Header (T : Character) is
657 Loc : Source_Ptr := No_Location;
658 -- Node whose Sloc is used for the decision
660 Nam : Name_Id := No_Name;
661 -- For the case of an aspect, aspect name
663 begin
664 case T is
665 when 'I' | 'E' | 'W' | 'a' | 'A' =>
667 -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of
668 -- the parent of the expression.
670 Loc := Sloc (Parent (N));
672 if T = 'a' or else T = 'A' then
673 Nam := Chars (Identifier (Parent (N)));
674 end if;
676 when 'G' | 'P' =>
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).
688 -- Doesn't this requirement of using First_Sloc need to be
689 -- documented in the spec ???
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;
700 when 'X' =>
702 -- For an expression, no Sloc
704 null;
706 -- No other possibilities
708 when others =>
709 raise Program_Error;
710 end case;
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);
721 -- For an aspect specification, which will be rewritten into a
722 -- pragma, enter a hash table entry now.
724 if T = 'a' then
725 Hash_Entries.Append ((Loc, SCO_Raw_Table.Last));
726 end if;
727 end Output_Header;
729 ------------------------------
730 -- Process_Decision_Operand --
731 ------------------------------
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;
741 Process_Decision_Operand (Right_Opnd (N));
743 else
744 Process_Decisions (N, 'X', Pragma_Sloc);
745 end if;
746 end Process_Decision_Operand;
748 ------------------
749 -- Process_Node --
750 ------------------
752 function Process_Node (N : Node_Id) return Traverse_Result is
753 begin
754 case Nkind (N) is
756 -- Logical operators, output table entries and then process
757 -- operands recursively to deal with nested conditions.
759 when N_And_Then
760 | N_Op_And
761 | N_Op_Not
762 | N_Op_Or
763 | N_Or_Else
765 declare
766 T : Character;
768 begin
769 -- If outer level, then type comes from call, otherwise it
770 -- is more deeply nested and counts as X for expression.
772 if N = Process_Decisions.N then
773 T := Process_Decisions.T;
774 else
775 T := 'X';
776 end if;
778 -- Output header for sequence
780 X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
781 Mark := SCO_Raw_Table.Last;
782 Mark_Hash := Hash_Entries.Last;
783 Output_Header (T);
785 -- Output the decision
787 Output_Decision_Operand (N);
789 -- If the decision was in an expression context (T = 'X')
790 -- and contained only NOT operators, then we don't output
791 -- it, so delete it.
793 if X_Not_Decision then
794 SCO_Raw_Table.Set_Last (Mark);
795 Hash_Entries.Set_Last (Mark_Hash);
797 -- Otherwise, set Last in last table entry to mark end
799 else
800 SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True;
801 end if;
803 -- Process any embedded decisions
805 Process_Decision_Operand (N);
806 return Skip;
807 end;
809 -- Case expression
811 -- Really hard to believe this is correct given the special
812 -- handling for if expressions below ???
814 when N_Case_Expression =>
815 return OK; -- ???
817 -- If expression, processed like an if statement
819 when N_If_Expression =>
820 declare
821 Cond : constant Node_Id := First (Expressions (N));
822 Thnx : constant Node_Id := Next (Cond);
823 Elsx : constant Node_Id := Next (Thnx);
825 begin
826 Process_Decisions (Cond, 'I', Pragma_Sloc);
827 Process_Decisions (Thnx, 'X', Pragma_Sloc);
828 Process_Decisions (Elsx, 'X', Pragma_Sloc);
829 return Skip;
830 end;
832 -- All other cases, continue scan
834 when others =>
835 return OK;
836 end case;
837 end Process_Node;
839 procedure Traverse is new Traverse_Proc (Process_Node);
841 -- Start of processing for Process_Decisions
843 begin
844 if No (N) then
845 return;
846 end if;
848 Hash_Entries.Init;
850 -- See if we have simple decision at outer level and if so then
851 -- generate the decision entry for this simple decision. A simple
852 -- decision is a boolean expression (which is not a logical operator
853 -- or short circuit form) appearing as the operand of an IF, WHILE,
854 -- EXIT WHEN, or special PRAGMA construct.
856 if T /= 'X' and then Is_Logical_Operator (N) = False then
857 Output_Header (T);
858 Output_Element (N);
860 -- Change Last in last table entry to True to mark end of
861 -- sequence, which is this case is only one element long.
863 SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True;
864 end if;
866 Traverse (N);
868 -- Now we have the definitive set of SCO entries, register them in the
869 -- corresponding hash table.
871 for J in 1 .. Hash_Entries.Last loop
872 SCO_Raw_Hash_Table.Set
873 (Hash_Entries.Table (J).Sloc,
874 Hash_Entries.Table (J).SCO_Index);
875 end loop;
877 Hash_Entries.Free;
878 end Process_Decisions;
880 -----------
881 -- pscos --
882 -----------
884 procedure pscos is
885 procedure Write_Info_Char (C : Character) renames Write_Char;
886 -- Write one character;
888 procedure Write_Info_Initiate (Key : Character) renames Write_Char;
889 -- Start new one and write one character;
891 procedure Write_Info_Nat (N : Nat);
892 -- Write value of N
894 procedure Write_Info_Terminate renames Write_Eol;
895 -- Terminate current line
897 --------------------
898 -- Write_Info_Nat --
899 --------------------
901 procedure Write_Info_Nat (N : Nat) is
902 begin
903 Write_Int (N);
904 end Write_Info_Nat;
906 procedure Debug_Put_SCOs is new Put_SCOs;
908 -- Start of processing for pscos
910 begin
911 Debug_Put_SCOs;
912 end pscos;
914 ---------------------
915 -- Record_Instance --
916 ---------------------
918 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is
919 Inst_Src : constant Source_File_Index :=
920 Get_Source_File_Index (Inst_Sloc);
921 begin
922 SCO_Instance_Table.Append
923 ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)),
924 Inst_Loc => To_Source_Location (Inst_Sloc),
925 Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src))));
927 pragma Assert
928 (SCO_Instance_Table.Last = SCO_Instance_Index (Id));
929 end Record_Instance;
931 ----------------
932 -- SCO_Output --
933 ----------------
935 procedure SCO_Output is
936 procedure Populate_SCO_Instance_Table is
937 new Sinput.Iterate_On_Instances (Record_Instance);
939 begin
940 pragma Assert (SCO_Generation_State = Filtered);
942 if Debug_Flag_Dot_OO then
943 dsco;
944 end if;
946 Populate_SCO_Instance_Table;
948 -- Sort the unit tables based on dependency numbers
950 Unit_Table_Sort : declare
951 function Lt (Op1 : Natural; Op2 : Natural) return Boolean;
952 -- Comparison routine for sort call
954 procedure Move (From : Natural; To : Natural);
955 -- Move routine for sort call
957 --------
958 -- Lt --
959 --------
961 function Lt (Op1 : Natural; Op2 : Natural) return Boolean is
962 begin
963 return
964 Dependency_Num
965 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
967 Dependency_Num
968 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
969 end Lt;
971 ----------
972 -- Move --
973 ----------
975 procedure Move (From : Natural; To : Natural) is
976 begin
977 SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
978 SCO_Unit_Table.Table (SCO_Unit_Index (From));
979 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
980 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
981 end Move;
983 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
985 -- Start of processing for Unit_Table_Sort
987 begin
988 Sorting.Sort (Integer (SCO_Unit_Table.Last));
989 end Unit_Table_Sort;
991 -- Loop through entries in the unit table to set file name and
992 -- dependency number entries.
994 for J in 1 .. SCO_Unit_Table.Last loop
995 declare
996 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
997 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
999 begin
1000 Get_Name_String (Reference_Name (Source_Index (U)));
1001 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
1002 UTE.Dep_Num := Dependency_Num (U);
1003 end;
1004 end loop;
1006 -- Now the tables are all setup for output to the ALI file
1008 Write_SCOs_To_ALI_File;
1009 end SCO_Output;
1011 -------------------------
1012 -- SCO_Pragma_Disabled --
1013 -------------------------
1015 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
1016 Index : Nat;
1018 begin
1019 if Loc = No_Location then
1020 return False;
1021 end if;
1023 Index := SCO_Raw_Hash_Table.Get (Loc);
1025 -- The test here for zero is to deal with possible previous errors, and
1026 -- for the case of pragma statement SCOs, for which we always set the
1027 -- Pragma_Sloc even if the particular pragma cannot be specifically
1028 -- disabled.
1030 if Index /= 0 then
1031 declare
1032 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
1034 begin
1035 case T.C1 is
1036 when 'S' =>
1037 -- Pragma statement
1039 return T.C2 = 'p';
1041 when 'A' =>
1042 -- Aspect decision (enabled)
1044 return False;
1046 when 'a' =>
1047 -- Aspect decision (not enabled)
1049 return True;
1051 when ASCII.NUL =>
1052 -- Nullified disabled SCO
1054 return True;
1056 when others =>
1057 raise Program_Error;
1058 end case;
1059 end;
1061 else
1062 return False;
1063 end if;
1064 end SCO_Pragma_Disabled;
1066 --------------------
1067 -- SCO_Record_Raw --
1068 --------------------
1070 procedure SCO_Record_Raw (U : Unit_Number_Type) is
1071 procedure Traverse_Aux_Decls (N : Node_Id);
1072 -- Traverse the Aux_Decls_Node of compilation unit N
1074 ------------------------
1075 -- Traverse_Aux_Decls --
1076 ------------------------
1078 procedure Traverse_Aux_Decls (N : Node_Id) is
1079 ADN : constant Node_Id := Aux_Decls_Node (N);
1081 begin
1082 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
1083 Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
1085 -- Declarations and Actions do not correspond to source constructs,
1086 -- they contain only nodes from expansion, so at this point they
1087 -- should still be empty:
1089 pragma Assert (No (Declarations (ADN)));
1090 pragma Assert (No (Actions (ADN)));
1091 end Traverse_Aux_Decls;
1093 -- Local variables
1095 From : Nat;
1096 Lu : Node_Id;
1098 -- Start of processing for SCO_Record_Raw
1100 begin
1101 -- It is legitimate to run this pass multiple times (once per unit) so
1102 -- run it even if it was already run before.
1104 pragma Assert (SCO_Generation_State in None .. Raw);
1105 SCO_Generation_State := Raw;
1107 -- Ignore call if not generating code and generating SCO's
1109 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
1110 return;
1111 end if;
1113 -- Ignore call if this unit already recorded
1115 for J in 1 .. SCO_Unit_Number_Table.Last loop
1116 if U = SCO_Unit_Number_Table.Table (J) then
1117 return;
1118 end if;
1119 end loop;
1121 -- Otherwise record starting entry
1123 From := SCO_Raw_Table.Last + 1;
1125 -- Get Unit (checking case of subunit)
1127 Lu := Unit (Cunit (U));
1129 if Nkind (Lu) = N_Subunit then
1130 Lu := Proper_Body (Lu);
1131 end if;
1133 -- Traverse the unit
1135 Traverse_Aux_Decls (Cunit (U));
1137 case Nkind (Lu) is
1138 when N_Generic_Instantiation
1139 | N_Generic_Package_Declaration
1140 | N_Package_Body
1141 | N_Package_Declaration
1142 | N_Protected_Body
1143 | N_Subprogram_Body
1144 | N_Subprogram_Declaration
1145 | N_Task_Body
1147 Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
1149 -- All other cases of compilation units (e.g. renamings), generate no
1150 -- SCO information.
1152 when others =>
1153 null;
1154 end case;
1156 -- Make entry for new unit in unit tables, we will fill in the file
1157 -- name and dependency numbers later.
1159 SCO_Unit_Table.Append (
1160 (Dep_Num => 0,
1161 File_Name => null,
1162 File_Index => Get_Source_File_Index (Sloc (Lu)),
1163 From => From,
1164 To => SCO_Raw_Table.Last));
1166 SCO_Unit_Number_Table.Append (U);
1167 end SCO_Record_Raw;
1169 -----------------------
1170 -- Set_SCO_Condition --
1171 -----------------------
1173 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
1175 -- SCO annotations are not processed after the filtering pass
1177 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1179 Constant_Condition_Code : constant array (Boolean) of Character :=
1180 (False => 'f', True => 't');
1182 Orig : constant Node_Id := Original_Node (Cond);
1183 Dummy : Source_Ptr;
1184 Index : Nat;
1185 Start : Source_Ptr;
1187 begin
1188 Sloc_Range (Orig, Start, Dummy);
1189 Index := SCO_Raw_Hash_Table.Get (Start);
1191 -- Index can be zero for boolean expressions that do not have SCOs
1192 -- (simple decisions outside of a control flow structure), or in case
1193 -- of a previous error.
1195 if Index = 0 then
1196 return;
1198 else
1199 pragma Assert (SCO_Raw_Table.Table (Index).C1 = ' ');
1200 SCO_Raw_Table.Table (Index).C2 := Constant_Condition_Code (Val);
1201 end if;
1202 end Set_SCO_Condition;
1204 ------------------------------
1205 -- Set_SCO_Logical_Operator --
1206 ------------------------------
1208 procedure Set_SCO_Logical_Operator (Op : Node_Id) is
1210 -- SCO annotations are not processed after the filtering pass
1212 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1214 Orig : constant Node_Id := Original_Node (Op);
1215 Orig_Sloc : constant Source_Ptr := Sloc (Orig);
1216 Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc);
1218 begin
1219 -- All (putative) logical operators are supposed to have their own entry
1220 -- in the SCOs table. However, the semantic analysis may invoke this
1221 -- subprogram with nodes that are out of the SCO generation scope.
1223 if Index /= 0 then
1224 SCO_Raw_Table.Table (Index).C2 := ' ';
1225 end if;
1226 end Set_SCO_Logical_Operator;
1228 ----------------------------
1229 -- Set_SCO_Pragma_Enabled --
1230 ----------------------------
1232 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
1234 -- SCO annotations are not processed after the filtering pass
1236 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1238 Index : Nat;
1240 begin
1241 -- Nothing to do if not generating SCO, or if we're not processing the
1242 -- original source occurrence of the pragma.
1244 if not (Generate_SCO
1245 and then In_Extended_Main_Source_Unit (Loc)
1246 and then not (In_Instance or In_Inlined_Body))
1247 then
1248 return;
1249 end if;
1251 -- Note: the reason we use the Sloc value as the key is that in the
1252 -- generic case, the call to this procedure is made on a copy of the
1253 -- original node, so we can't use the Node_Id value.
1255 Index := SCO_Raw_Hash_Table.Get (Loc);
1257 -- A zero index here indicates that semantic analysis found an
1258 -- activated pragma at Loc which does not have a corresponding pragma
1259 -- or aspect at the syntax level. This may occur in legitimate cases
1260 -- because of expanded code (such are Pre/Post conditions generated for
1261 -- formal parameter validity checks), or as a consequence of a previous
1262 -- error.
1264 if Index = 0 then
1265 return;
1267 else
1268 declare
1269 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
1271 begin
1272 -- Note: may be called multiple times for the same sloc, so
1273 -- account for the fact that the entry may already have been
1274 -- marked enabled.
1276 case T.C1 is
1277 -- Aspect (decision SCO)
1279 when 'a' =>
1280 T.C1 := 'A';
1282 when 'A' =>
1283 null;
1285 -- Pragma (statement SCO)
1287 when 'S' =>
1288 pragma Assert (T.C2 = 'p' or else T.C2 = 'P');
1289 T.C2 := 'P';
1291 when others =>
1292 raise Program_Error;
1293 end case;
1294 end;
1295 end if;
1296 end Set_SCO_Pragma_Enabled;
1298 -------------------------
1299 -- Set_Raw_Table_Entry --
1300 -------------------------
1302 procedure Set_Raw_Table_Entry
1303 (C1 : Character;
1304 C2 : Character;
1305 From : Source_Ptr;
1306 To : Source_Ptr;
1307 Last : Boolean;
1308 Pragma_Sloc : Source_Ptr := No_Location;
1309 Pragma_Aspect_Name : Name_Id := No_Name)
1311 pragma Assert (SCO_Generation_State = Raw);
1312 begin
1313 SCO_Raw_Table.Append
1314 ((C1 => C1,
1315 C2 => C2,
1316 From => To_Source_Location (From),
1317 To => To_Source_Location (To),
1318 Last => Last,
1319 Pragma_Sloc => Pragma_Sloc,
1320 Pragma_Aspect_Name => Pragma_Aspect_Name));
1321 end Set_Raw_Table_Entry;
1323 ------------------------
1324 -- To_Source_Location --
1325 ------------------------
1327 function To_Source_Location (S : Source_Ptr) return Source_Location is
1328 begin
1329 if S = No_Location then
1330 return No_Source_Location;
1331 else
1332 return
1333 (Line => Get_Logical_Line_Number (S),
1334 Col => Get_Column_Number (S));
1335 end if;
1336 end To_Source_Location;
1338 -----------------------------------------
1339 -- Traverse_Declarations_Or_Statements --
1340 -----------------------------------------
1342 -- Tables used by Traverse_Declarations_Or_Statements for temporarily
1343 -- holding statement and decision entries. These are declared globally
1344 -- since they are shared by recursive calls to this procedure.
1346 type SC_Entry is record
1347 N : Node_Id;
1348 From : Source_Ptr;
1349 To : Source_Ptr;
1350 Typ : Character;
1351 end record;
1352 -- Used to store a single entry in the following table, From:To represents
1353 -- the range of entries in the CS line entry, and typ is the type, with
1354 -- space meaning that no type letter will accompany the entry.
1356 package SC is new Table.Table
1357 (Table_Component_Type => SC_Entry,
1358 Table_Index_Type => Nat,
1359 Table_Low_Bound => 1,
1360 Table_Initial => 1000,
1361 Table_Increment => 200,
1362 Table_Name => "SCO_SC");
1363 -- Used to store statement components for a CS entry to be output as a
1364 -- result of the call to this procedure. SC.Last is the last entry stored,
1365 -- so the current statement sequence is represented by SC_Array (SC_First
1366 -- .. SC.Last), where SC_First is saved on entry to each recursive call to
1367 -- the routine.
1369 -- Extend_Statement_Sequence adds an entry to this array, and then
1370 -- Set_Statement_Entry clears the entries starting with SC_First, copying
1371 -- these entries to the main SCO output table. The reason that we do the
1372 -- temporary caching of results in this array is that we want the SCO table
1373 -- entries for a given CS line to be contiguous, and the processing may
1374 -- output intermediate entries such as decision entries.
1376 type SD_Entry is record
1377 Nod : Node_Id;
1378 Lst : List_Id;
1379 Typ : Character;
1380 Plo : Source_Ptr;
1381 end record;
1382 -- Used to store a single entry in the following table. Nod is the node to
1383 -- be searched for decisions for the case of Process_Decisions_Defer with a
1384 -- node argument (with Lst set to No_List. Lst is the list to be searched
1385 -- for decisions for the case of Process_Decisions_Defer with a List
1386 -- argument (in which case Nod is set to Empty). Plo is the sloc of the
1387 -- enclosing pragma, if any.
1389 package SD is new Table.Table
1390 (Table_Component_Type => SD_Entry,
1391 Table_Index_Type => Nat,
1392 Table_Low_Bound => 1,
1393 Table_Initial => 1000,
1394 Table_Increment => 200,
1395 Table_Name => "SCO_SD");
1396 -- Used to store possible decision information. Instead of calling the
1397 -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
1398 -- which simply stores the arguments in this table. Then when we clear
1399 -- out a statement sequence using Set_Statement_Entry, after generating
1400 -- the CS lines for the statements, the entries in this table result in
1401 -- calls to Process_Decision. The reason for doing things this way is to
1402 -- ensure that decisions are output after the CS line for the statements
1403 -- in which the decisions occur.
1405 procedure Traverse_Declarations_Or_Statements
1406 (L : List_Id;
1407 D : Dominant_Info := No_Dominant;
1408 P : Node_Id := Empty)
1410 Discard_Dom : Dominant_Info;
1411 pragma Warnings (Off, Discard_Dom);
1412 begin
1413 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P);
1414 end Traverse_Declarations_Or_Statements;
1416 function Traverse_Declarations_Or_Statements
1417 (L : List_Id;
1418 D : Dominant_Info := No_Dominant;
1419 P : Node_Id := Empty) return Dominant_Info
1421 Current_Dominant : Dominant_Info := D;
1422 -- Dominance information for the current basic block
1424 Current_Test : Node_Id;
1425 -- Conditional node (N_If_Statement or N_Elsiif being processed
1427 N : Node_Id;
1429 SC_First : constant Nat := SC.Last + 1;
1430 SD_First : constant Nat := SD.Last + 1;
1431 -- Record first entries used in SC/SD at this recursive level
1433 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
1434 -- Extend the current statement sequence to encompass the node N. Typ is
1435 -- the letter that identifies the type of statement/declaration that is
1436 -- being added to the sequence.
1438 procedure Process_Decisions_Defer (N : Node_Id; T : Character);
1439 pragma Inline (Process_Decisions_Defer);
1440 -- This routine is logically the same as Process_Decisions, except that
1441 -- the arguments are saved in the SD table for later processing when
1442 -- Set_Statement_Entry is called, which goes through the saved entries
1443 -- making the corresponding calls to Process_Decision. Note: the
1444 -- enclosing statement must have already been added to the current
1445 -- statement sequence, so that nested decisions are properly
1446 -- identified as such.
1448 procedure Process_Decisions_Defer (L : List_Id; T : Character);
1449 pragma Inline (Process_Decisions_Defer);
1450 -- Same case for list arguments, deferred call to Process_Decisions
1452 procedure Set_Statement_Entry;
1453 -- Output CS entries for all statements saved in table SC, and end the
1454 -- current CS sequence. Then output entries for all decisions nested in
1455 -- these statements, which have been deferred so far.
1457 procedure Traverse_One (N : Node_Id);
1458 -- Traverse one declaration or statement
1460 procedure Traverse_Aspects (N : Node_Id);
1461 -- Helper for Traverse_One: traverse N's aspect specifications
1463 procedure Traverse_Degenerate_Subprogram (N : Node_Id);
1464 -- Common code to handle null procedures and expression functions. Emit
1465 -- a SCO of the given Kind and N outside of the dominance flow.
1467 -------------------------------
1468 -- Extend_Statement_Sequence --
1469 -------------------------------
1471 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1472 Dummy : Source_Ptr;
1473 F : Source_Ptr;
1474 T : Source_Ptr;
1475 To_Node : Node_Id := Empty;
1477 begin
1478 Sloc_Range (N, F, T);
1480 case Nkind (N) is
1481 when N_Accept_Statement =>
1482 if Present (Parameter_Specifications (N)) then
1483 To_Node := Last (Parameter_Specifications (N));
1484 elsif Present (Entry_Index (N)) then
1485 To_Node := Entry_Index (N);
1486 else
1487 To_Node := Entry_Direct_Name (N);
1488 end if;
1490 when N_Case_Statement =>
1491 To_Node := Expression (N);
1493 when N_Elsif_Part
1494 | N_If_Statement
1496 To_Node := Condition (N);
1498 when N_Extended_Return_Statement =>
1499 To_Node := Last (Return_Object_Declarations (N));
1501 when N_Loop_Statement =>
1502 To_Node := Iteration_Scheme (N);
1504 when N_Asynchronous_Select
1505 | N_Conditional_Entry_Call
1506 | N_Selective_Accept
1507 | N_Single_Protected_Declaration
1508 | N_Single_Task_Declaration
1509 | N_Timed_Entry_Call
1511 T := F;
1513 when N_Protected_Type_Declaration
1514 | N_Task_Type_Declaration
1516 if Has_Aspects (N) then
1517 To_Node := Last (Aspect_Specifications (N));
1519 elsif Present (Discriminant_Specifications (N)) then
1520 To_Node := Last (Discriminant_Specifications (N));
1522 else
1523 To_Node := Defining_Identifier (N);
1524 end if;
1526 when N_Subexpr =>
1527 To_Node := N;
1529 when others =>
1530 null;
1531 end case;
1533 if Present (To_Node) then
1534 Sloc_Range (To_Node, Dummy, T);
1535 end if;
1537 SC.Append ((N, F, T, Typ));
1538 end Extend_Statement_Sequence;
1540 -----------------------------
1541 -- Process_Decisions_Defer --
1542 -----------------------------
1544 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1545 begin
1546 SD.Append ((N, No_List, T, Current_Pragma_Sloc));
1547 end Process_Decisions_Defer;
1549 procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1550 begin
1551 SD.Append ((Empty, L, T, Current_Pragma_Sloc));
1552 end Process_Decisions_Defer;
1554 -------------------------
1555 -- Set_Statement_Entry --
1556 -------------------------
1558 procedure Set_Statement_Entry is
1559 SC_Last : constant Int := SC.Last;
1560 SD_Last : constant Int := SD.Last;
1562 begin
1563 -- Output statement entries from saved entries in SC table
1565 for J in SC_First .. SC_Last loop
1566 if J = SC_First then
1568 if Current_Dominant /= No_Dominant then
1569 declare
1570 From : Source_Ptr;
1571 To : Source_Ptr;
1573 begin
1574 Sloc_Range (Current_Dominant.N, From, To);
1576 if Current_Dominant.K /= 'E' then
1577 To := No_Location;
1578 end if;
1580 Set_Raw_Table_Entry
1581 (C1 => '>',
1582 C2 => Current_Dominant.K,
1583 From => From,
1584 To => To,
1585 Last => False,
1586 Pragma_Sloc => No_Location,
1587 Pragma_Aspect_Name => No_Name);
1588 end;
1589 end if;
1590 end if;
1592 declare
1593 SCE : SC_Entry renames SC.Table (J);
1594 Pragma_Sloc : Source_Ptr := No_Location;
1595 Pragma_Aspect_Name : Name_Id := No_Name;
1597 begin
1598 -- For the case of a statement SCO for a pragma controlled by
1599 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
1600 -- those of any nested decision) is emitted only if the pragma
1601 -- is enabled.
1603 if SCE.Typ = 'p' then
1604 Pragma_Sloc := SCE.From;
1605 SCO_Raw_Hash_Table.Set
1606 (Pragma_Sloc, SCO_Raw_Table.Last + 1);
1607 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
1608 pragma Assert (Pragma_Aspect_Name /= No_Name);
1610 elsif SCE.Typ = 'P' then
1611 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
1612 pragma Assert (Pragma_Aspect_Name /= No_Name);
1613 end if;
1615 Set_Raw_Table_Entry
1616 (C1 => 'S',
1617 C2 => SCE.Typ,
1618 From => SCE.From,
1619 To => SCE.To,
1620 Last => (J = SC_Last),
1621 Pragma_Sloc => Pragma_Sloc,
1622 Pragma_Aspect_Name => Pragma_Aspect_Name);
1623 end;
1624 end loop;
1626 -- Last statement of basic block, if present, becomes new current
1627 -- dominant.
1629 if SC_Last >= SC_First then
1630 Current_Dominant := ('S', SC.Table (SC_Last).N);
1631 end if;
1633 -- Clear out used section of SC table
1635 SC.Set_Last (SC_First - 1);
1637 -- Output any embedded decisions
1639 for J in SD_First .. SD_Last loop
1640 declare
1641 SDE : SD_Entry renames SD.Table (J);
1643 begin
1644 if Present (SDE.Nod) then
1645 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
1646 else
1647 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
1648 end if;
1649 end;
1650 end loop;
1652 -- Clear out used section of SD table
1654 SD.Set_Last (SD_First - 1);
1655 end Set_Statement_Entry;
1657 ----------------------
1658 -- Traverse_Aspects --
1659 ----------------------
1661 procedure Traverse_Aspects (N : Node_Id) is
1662 AE : Node_Id;
1663 AN : Node_Id;
1664 C1 : Character;
1666 begin
1667 AN := First (Aspect_Specifications (N));
1668 while Present (AN) loop
1669 AE := Expression (AN);
1671 -- SCOs are generated before semantic analysis/expansion:
1672 -- PPCs are not split yet.
1674 pragma Assert (not Split_PPC (AN));
1676 C1 := ASCII.NUL;
1678 case Get_Aspect_Id (AN) is
1680 -- Aspects rewritten into pragmas controlled by a Check_Policy:
1681 -- Current_Pragma_Sloc must be set to the sloc of the aspect
1682 -- specification. The corresponding pragma will have the same
1683 -- sloc. Note that Invariant, Pre, and Post will be enabled if
1684 -- the policy is Check; on the other hand, predicate aspects
1685 -- will be enabled for Check and Ignore (when Add_Predicate
1686 -- is called) because the actual checks occur in client units.
1687 -- When the assertion policy for Predicate is Disable, the
1688 -- SCO remains disabled, because Add_Predicate is never called.
1690 -- Pre/post can have checks in client units too because of
1691 -- inheritance, so should they receive the same treatment???
1693 when Aspect_Dynamic_Predicate
1694 | Aspect_Invariant
1695 | Aspect_Post
1696 | Aspect_Postcondition
1697 | Aspect_Pre
1698 | Aspect_Precondition
1699 | Aspect_Predicate
1700 | Aspect_Static_Predicate
1701 | Aspect_Type_Invariant
1703 C1 := 'a';
1705 -- Other aspects: just process any decision nested in the
1706 -- aspect expression.
1708 when others =>
1709 if Has_Decision (AE) then
1710 C1 := 'X';
1711 end if;
1712 end case;
1714 if C1 /= ASCII.NUL then
1715 pragma Assert (Current_Pragma_Sloc = No_Location);
1717 if C1 = 'a' or else C1 = 'A' then
1718 Current_Pragma_Sloc := Sloc (AN);
1719 end if;
1721 Process_Decisions_Defer (AE, C1);
1723 Current_Pragma_Sloc := No_Location;
1724 end if;
1726 Next (AN);
1727 end loop;
1728 end Traverse_Aspects;
1730 ------------------------------------
1731 -- Traverse_Degenerate_Subprogram --
1732 ------------------------------------
1734 procedure Traverse_Degenerate_Subprogram (N : Node_Id) is
1735 begin
1736 -- Complete current sequence of statements
1738 Set_Statement_Entry;
1740 declare
1741 Saved_Dominant : constant Dominant_Info := Current_Dominant;
1742 -- Save last statement in current sequence as dominant
1744 begin
1745 -- Output statement SCO for degenerate subprogram body (null
1746 -- statement or freestanding expression) outside of the dominance
1747 -- chain.
1749 Current_Dominant := No_Dominant;
1750 Extend_Statement_Sequence (N, Typ => ' ');
1752 -- For the case of an expression-function, collect decisions
1753 -- embedded in the expression now.
1755 if Nkind (N) in N_Subexpr then
1756 Process_Decisions_Defer (N, 'X');
1757 end if;
1759 Set_Statement_Entry;
1761 -- Restore current dominant information designating last statement
1762 -- in previous sequence (i.e. make the dominance chain skip over
1763 -- the degenerate body).
1765 Current_Dominant := Saved_Dominant;
1766 end;
1767 end Traverse_Degenerate_Subprogram;
1769 ------------------
1770 -- Traverse_One --
1771 ------------------
1773 procedure Traverse_One (N : Node_Id) is
1774 begin
1775 -- Initialize or extend current statement sequence. Note that for
1776 -- special cases such as IF and Case statements we will modify
1777 -- the range to exclude internal statements that should not be
1778 -- counted as part of the current statement sequence.
1780 case Nkind (N) is
1782 -- Package declaration
1784 when N_Package_Declaration =>
1785 Set_Statement_Entry;
1786 Traverse_Package_Declaration (N, Current_Dominant);
1788 -- Generic package declaration
1790 when N_Generic_Package_Declaration =>
1791 Set_Statement_Entry;
1792 Traverse_Generic_Package_Declaration (N);
1794 -- Package body
1796 when N_Package_Body =>
1797 Set_Statement_Entry;
1798 Traverse_Package_Body (N);
1800 -- Subprogram declaration or subprogram body stub
1802 when N_Expression_Function
1803 | N_Subprogram_Body_Stub
1804 | N_Subprogram_Declaration
1806 declare
1807 Spec : constant Node_Id := Specification (N);
1808 begin
1809 Process_Decisions_Defer
1810 (Parameter_Specifications (Spec), 'X');
1812 -- Case of a null procedure: generate SCO for fictitious
1813 -- NULL statement located at the NULL keyword in the
1814 -- procedure specification.
1816 if Nkind (N) = N_Subprogram_Declaration
1817 and then Nkind (Spec) = N_Procedure_Specification
1818 and then Null_Present (Spec)
1819 then
1820 Traverse_Degenerate_Subprogram (Null_Statement (Spec));
1822 -- Case of an expression function: generate a statement SCO
1823 -- for the expression (and then decision SCOs for any nested
1824 -- decisions).
1826 elsif Nkind (N) = N_Expression_Function then
1827 Traverse_Degenerate_Subprogram (Expression (N));
1828 end if;
1829 end;
1831 -- Entry declaration
1833 when N_Entry_Declaration =>
1834 Process_Decisions_Defer (Parameter_Specifications (N), 'X');
1836 -- Generic subprogram declaration
1838 when N_Generic_Subprogram_Declaration =>
1839 Process_Decisions_Defer
1840 (Generic_Formal_Declarations (N), 'X');
1841 Process_Decisions_Defer
1842 (Parameter_Specifications (Specification (N)), 'X');
1844 -- Task or subprogram body
1846 when N_Subprogram_Body
1847 | N_Task_Body
1849 Set_Statement_Entry;
1850 Traverse_Subprogram_Or_Task_Body (N);
1852 -- Entry body
1854 when N_Entry_Body =>
1855 declare
1856 Cond : constant Node_Id :=
1857 Condition (Entry_Body_Formal_Part (N));
1859 Inner_Dominant : Dominant_Info := No_Dominant;
1861 begin
1862 Set_Statement_Entry;
1864 if Present (Cond) then
1865 Process_Decisions_Defer (Cond, 'G');
1867 -- For an entry body with a barrier, the entry body
1868 -- is dominanted by a True evaluation of the barrier.
1870 Inner_Dominant := ('T', N);
1871 end if;
1873 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
1874 end;
1876 -- Protected body
1878 when N_Protected_Body =>
1879 Set_Statement_Entry;
1880 Traverse_Declarations_Or_Statements (Declarations (N));
1882 -- Exit statement, which is an exit statement in the SCO sense,
1883 -- so it is included in the current statement sequence, but
1884 -- then it terminates this sequence. We also have to process
1885 -- any decisions in the exit statement expression.
1887 when N_Exit_Statement =>
1888 Extend_Statement_Sequence (N, 'E');
1889 Process_Decisions_Defer (Condition (N), 'E');
1890 Set_Statement_Entry;
1892 -- If condition is present, then following statement is
1893 -- only executed if the condition evaluates to False.
1895 if Present (Condition (N)) then
1896 Current_Dominant := ('F', N);
1897 else
1898 Current_Dominant := No_Dominant;
1899 end if;
1901 -- Label, which breaks the current statement sequence, but the
1902 -- label itself is not included in the next statement sequence,
1903 -- since it generates no code.
1905 when N_Label =>
1906 Set_Statement_Entry;
1907 Current_Dominant := No_Dominant;
1909 -- Block statement, which breaks the current statement sequence
1911 when N_Block_Statement =>
1912 Set_Statement_Entry;
1914 -- The first statement in the handled sequence of statements
1915 -- is dominated by the elaboration of the last declaration.
1917 Current_Dominant := Traverse_Declarations_Or_Statements
1918 (L => Declarations (N),
1919 D => Current_Dominant);
1921 Traverse_Handled_Statement_Sequence
1922 (N => Handled_Statement_Sequence (N),
1923 D => Current_Dominant);
1925 -- If statement, which breaks the current statement sequence,
1926 -- but we include the condition in the current sequence.
1928 when N_If_Statement =>
1929 Current_Test := N;
1930 Extend_Statement_Sequence (N, 'I');
1931 Process_Decisions_Defer (Condition (N), 'I');
1932 Set_Statement_Entry;
1934 -- Now we traverse the statements in the THEN part
1936 Traverse_Declarations_Or_Statements
1937 (L => Then_Statements (N),
1938 D => ('T', N));
1940 -- Loop through ELSIF parts if present
1942 if Present (Elsif_Parts (N)) then
1943 declare
1944 Saved_Dominant : constant Dominant_Info :=
1945 Current_Dominant;
1947 Elif : Node_Id := First (Elsif_Parts (N));
1949 begin
1950 while Present (Elif) loop
1952 -- An Elsif is executed only if the previous test
1953 -- got a FALSE outcome.
1955 Current_Dominant := ('F', Current_Test);
1957 -- Now update current test information
1959 Current_Test := Elif;
1961 -- We generate a statement sequence for the
1962 -- construct "ELSIF condition", so that we have
1963 -- a statement for the resulting decisions.
1965 Extend_Statement_Sequence (Elif, 'I');
1966 Process_Decisions_Defer (Condition (Elif), 'I');
1967 Set_Statement_Entry;
1969 -- An ELSIF part is never guaranteed to have
1970 -- been executed, following statements are only
1971 -- dominated by the initial IF statement.
1973 Current_Dominant := Saved_Dominant;
1975 -- Traverse the statements in the ELSIF
1977 Traverse_Declarations_Or_Statements
1978 (L => Then_Statements (Elif),
1979 D => ('T', Elif));
1980 Next (Elif);
1981 end loop;
1982 end;
1983 end if;
1985 -- Finally traverse the ELSE statements if present
1987 Traverse_Declarations_Or_Statements
1988 (L => Else_Statements (N),
1989 D => ('F', Current_Test));
1991 -- CASE statement, which breaks the current statement sequence,
1992 -- but we include the expression in the current sequence.
1994 when N_Case_Statement =>
1995 Extend_Statement_Sequence (N, 'C');
1996 Process_Decisions_Defer (Expression (N), 'X');
1997 Set_Statement_Entry;
1999 -- Process case branches, all of which are dominated by the
2000 -- CASE statement.
2002 declare
2003 Alt : Node_Id;
2004 begin
2005 Alt := First_Non_Pragma (Alternatives (N));
2006 while Present (Alt) loop
2007 Traverse_Declarations_Or_Statements
2008 (L => Statements (Alt),
2009 D => Current_Dominant);
2010 Next (Alt);
2011 end loop;
2012 end;
2014 -- ACCEPT statement
2016 when N_Accept_Statement =>
2017 Extend_Statement_Sequence (N, 'A');
2018 Set_Statement_Entry;
2020 -- Process sequence of statements, dominant is the ACCEPT
2021 -- statement.
2023 Traverse_Handled_Statement_Sequence
2024 (N => Handled_Statement_Sequence (N),
2025 D => Current_Dominant);
2027 -- SELECT
2029 when N_Selective_Accept =>
2030 Extend_Statement_Sequence (N, 'S');
2031 Set_Statement_Entry;
2033 -- Process alternatives
2035 declare
2036 Alt : Node_Id;
2037 Guard : Node_Id;
2038 S_Dom : Dominant_Info;
2040 begin
2041 Alt := First (Select_Alternatives (N));
2042 while Present (Alt) loop
2043 S_Dom := Current_Dominant;
2044 Guard := Condition (Alt);
2046 if Present (Guard) then
2047 Process_Decisions
2048 (Guard,
2049 'G',
2050 Pragma_Sloc => No_Location);
2051 Current_Dominant := ('T', Guard);
2052 end if;
2054 Traverse_One (Alt);
2056 Current_Dominant := S_Dom;
2057 Next (Alt);
2058 end loop;
2059 end;
2061 Traverse_Declarations_Or_Statements
2062 (L => Else_Statements (N),
2063 D => Current_Dominant);
2065 when N_Conditional_Entry_Call
2066 | N_Timed_Entry_Call
2068 Extend_Statement_Sequence (N, 'S');
2069 Set_Statement_Entry;
2071 -- Process alternatives
2073 Traverse_One (Entry_Call_Alternative (N));
2075 if Nkind (N) = N_Timed_Entry_Call then
2076 Traverse_One (Delay_Alternative (N));
2077 else
2078 Traverse_Declarations_Or_Statements
2079 (L => Else_Statements (N),
2080 D => Current_Dominant);
2081 end if;
2083 when N_Asynchronous_Select =>
2084 Extend_Statement_Sequence (N, 'S');
2085 Set_Statement_Entry;
2087 Traverse_One (Triggering_Alternative (N));
2088 Traverse_Declarations_Or_Statements
2089 (L => Statements (Abortable_Part (N)),
2090 D => Current_Dominant);
2092 when N_Accept_Alternative =>
2093 Traverse_Declarations_Or_Statements
2094 (L => Statements (N),
2095 D => Current_Dominant,
2096 P => Accept_Statement (N));
2098 when N_Entry_Call_Alternative =>
2099 Traverse_Declarations_Or_Statements
2100 (L => Statements (N),
2101 D => Current_Dominant,
2102 P => Entry_Call_Statement (N));
2104 when N_Delay_Alternative =>
2105 Traverse_Declarations_Or_Statements
2106 (L => Statements (N),
2107 D => Current_Dominant,
2108 P => Delay_Statement (N));
2110 when N_Triggering_Alternative =>
2111 Traverse_Declarations_Or_Statements
2112 (L => Statements (N),
2113 D => Current_Dominant,
2114 P => Triggering_Statement (N));
2116 when N_Terminate_Alternative =>
2118 -- It is dubious to emit a statement SCO for a TERMINATE
2119 -- alternative, since no code is actually executed if the
2120 -- alternative is selected -- the tasking runtime call just
2121 -- never returns???
2123 Extend_Statement_Sequence (N, ' ');
2124 Set_Statement_Entry;
2126 -- Unconditional exit points, which are included in the current
2127 -- statement sequence, but then terminate it
2129 when N_Goto_Statement
2130 | N_Raise_Statement
2131 | N_Requeue_Statement
2133 Extend_Statement_Sequence (N, ' ');
2134 Set_Statement_Entry;
2135 Current_Dominant := No_Dominant;
2137 -- Simple return statement. which is an exit point, but we
2138 -- have to process the return expression for decisions.
2140 when N_Simple_Return_Statement =>
2141 Extend_Statement_Sequence (N, ' ');
2142 Process_Decisions_Defer (Expression (N), 'X');
2143 Set_Statement_Entry;
2144 Current_Dominant := No_Dominant;
2146 -- Extended return statement
2148 when N_Extended_Return_Statement =>
2149 Extend_Statement_Sequence (N, 'R');
2150 Process_Decisions_Defer (Return_Object_Declarations (N), 'X');
2151 Set_Statement_Entry;
2153 Traverse_Handled_Statement_Sequence
2154 (N => Handled_Statement_Sequence (N),
2155 D => Current_Dominant);
2157 Current_Dominant := No_Dominant;
2159 -- Loop ends the current statement sequence, but we include
2160 -- the iteration scheme if present in the current sequence.
2161 -- But the body of the loop starts a new sequence, since it
2162 -- may not be executed as part of the current sequence.
2164 when N_Loop_Statement =>
2165 declare
2166 ISC : constant Node_Id := Iteration_Scheme (N);
2167 Inner_Dominant : Dominant_Info := No_Dominant;
2169 begin
2170 if Present (ISC) then
2172 -- If iteration scheme present, extend the current
2173 -- statement sequence to include the iteration scheme
2174 -- and process any decisions it contains.
2176 -- While loop
2178 if Present (Condition (ISC)) then
2179 Extend_Statement_Sequence (N, 'W');
2180 Process_Decisions_Defer (Condition (ISC), 'W');
2182 -- Set more specific dominant for inner statements
2183 -- (the control sloc for the decision is that of
2184 -- the WHILE token).
2186 Inner_Dominant := ('T', ISC);
2188 -- For loop
2190 else
2191 Extend_Statement_Sequence (N, 'F');
2192 Process_Decisions_Defer
2193 (Loop_Parameter_Specification (ISC), 'X');
2194 end if;
2195 end if;
2197 Set_Statement_Entry;
2199 if Inner_Dominant = No_Dominant then
2200 Inner_Dominant := Current_Dominant;
2201 end if;
2203 Traverse_Declarations_Or_Statements
2204 (L => Statements (N),
2205 D => Inner_Dominant);
2206 end;
2208 -- Pragma
2210 when N_Pragma =>
2212 -- Record sloc of pragma (pragmas don't nest)
2214 pragma Assert (Current_Pragma_Sloc = No_Location);
2215 Current_Pragma_Sloc := Sloc (N);
2217 -- Processing depends on the kind of pragma
2219 declare
2220 Nam : constant Name_Id := Pragma_Name_Unmapped (N);
2221 Arg : Node_Id :=
2222 First (Pragma_Argument_Associations (N));
2223 Typ : Character;
2225 begin
2226 case Nam is
2227 when Name_Assert
2228 | Name_Assert_And_Cut
2229 | Name_Assume
2230 | Name_Check
2231 | Name_Loop_Invariant
2232 | Name_Postcondition
2233 | Name_Precondition
2235 -- For Assert/Check/Precondition/Postcondition, we
2236 -- must generate a P entry for the decision. Note
2237 -- that this is done unconditionally at this stage.
2238 -- Output for disabled pragmas is suppressed later
2239 -- on when we output the decision line in Put_SCOs,
2240 -- depending on setting by Set_SCO_Pragma_Enabled.
2242 if Nam = Name_Check then
2243 Next (Arg);
2244 end if;
2246 Process_Decisions_Defer (Expression (Arg), 'P');
2247 Typ := 'p';
2249 -- Pre/postconditions can be inherited so SCO should
2250 -- never be deactivated???
2252 when Name_Debug =>
2253 if Present (Arg) and then Present (Next (Arg)) then
2255 -- Case of a dyadic pragma Debug: first argument
2256 -- is a P decision, any nested decision in the
2257 -- second argument is an X decision.
2259 Process_Decisions_Defer (Expression (Arg), 'P');
2260 Next (Arg);
2261 end if;
2263 Process_Decisions_Defer (Expression (Arg), 'X');
2264 Typ := 'p';
2266 -- For all other pragmas, we generate decision entries
2267 -- for any embedded expressions, and the pragma is
2268 -- never disabled.
2270 -- Should generate P decisions (not X) for assertion
2271 -- related pragmas: [Type_]Invariant,
2272 -- [{Static,Dynamic}_]Predicate???
2274 when others =>
2275 Process_Decisions_Defer (N, 'X');
2276 Typ := 'P';
2277 end case;
2279 -- Add statement SCO
2281 Extend_Statement_Sequence (N, Typ);
2283 Current_Pragma_Sloc := No_Location;
2284 end;
2286 -- Object declaration. Ignored if Prev_Ids is set, since the
2287 -- parser generates multiple instances of the whole declaration
2288 -- if there is more than one identifier declared, and we only
2289 -- want one entry in the SCOs, so we take the first, for which
2290 -- Prev_Ids is False.
2292 when N_Number_Declaration
2293 | N_Object_Declaration
2295 if not Prev_Ids (N) then
2296 Extend_Statement_Sequence (N, 'o');
2298 if Has_Decision (N) then
2299 Process_Decisions_Defer (N, 'X');
2300 end if;
2301 end if;
2303 -- All other cases, which extend the current statement sequence
2304 -- but do not terminate it, even if they have nested decisions.
2306 when N_Protected_Type_Declaration
2307 | N_Task_Type_Declaration
2309 Extend_Statement_Sequence (N, 't');
2310 Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
2311 Set_Statement_Entry;
2313 Traverse_Sync_Definition (N);
2315 when N_Single_Protected_Declaration
2316 | N_Single_Task_Declaration
2318 Extend_Statement_Sequence (N, 'o');
2319 Set_Statement_Entry;
2321 Traverse_Sync_Definition (N);
2323 when others =>
2325 -- Determine required type character code, or ASCII.NUL if
2326 -- no SCO should be generated for this node.
2328 declare
2329 NK : constant Node_Kind := Nkind (N);
2330 Typ : Character;
2332 begin
2333 case NK is
2334 when N_Full_Type_Declaration
2335 | N_Incomplete_Type_Declaration
2336 | N_Private_Extension_Declaration
2337 | N_Private_Type_Declaration
2339 Typ := 't';
2341 when N_Subtype_Declaration =>
2342 Typ := 's';
2344 when N_Renaming_Declaration =>
2345 Typ := 'r';
2347 when N_Generic_Instantiation =>
2348 Typ := 'i';
2350 when N_Package_Body_Stub
2351 | N_Protected_Body_Stub
2352 | N_Representation_Clause
2353 | N_Task_Body_Stub
2354 | N_Use_Package_Clause
2355 | N_Use_Type_Clause
2357 Typ := ASCII.NUL;
2359 when N_Procedure_Call_Statement =>
2360 Typ := ' ';
2362 when others =>
2363 if NK in N_Statement_Other_Than_Procedure_Call then
2364 Typ := ' ';
2365 else
2366 Typ := 'd';
2367 end if;
2368 end case;
2370 if Typ /= ASCII.NUL then
2371 Extend_Statement_Sequence (N, Typ);
2372 end if;
2373 end;
2375 -- Process any embedded decisions
2377 if Has_Decision (N) then
2378 Process_Decisions_Defer (N, 'X');
2379 end if;
2380 end case;
2382 -- Process aspects if present
2384 Traverse_Aspects (N);
2385 end Traverse_One;
2387 -- Start of processing for Traverse_Declarations_Or_Statements
2389 begin
2390 -- Process single prefixed node
2392 if Present (P) then
2393 Traverse_One (P);
2394 end if;
2396 -- Loop through statements or declarations
2398 if Is_Non_Empty_List (L) then
2399 N := First (L);
2400 while Present (N) loop
2402 -- Note: For separate bodies, we see the tree after Par.Labl has
2403 -- introduced implicit labels, so we need to ignore those nodes.
2405 if Nkind (N) /= N_Implicit_Label_Declaration then
2406 Traverse_One (N);
2407 end if;
2409 Next (N);
2410 end loop;
2412 end if;
2414 -- End sequence of statements and flush deferred decisions
2416 if Present (P) or else Is_Non_Empty_List (L) then
2417 Set_Statement_Entry;
2418 end if;
2420 return Current_Dominant;
2421 end Traverse_Declarations_Or_Statements;
2423 ------------------------------------------
2424 -- Traverse_Generic_Package_Declaration --
2425 ------------------------------------------
2427 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
2428 begin
2429 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
2430 Traverse_Package_Declaration (N);
2431 end Traverse_Generic_Package_Declaration;
2433 -----------------------------------------
2434 -- Traverse_Handled_Statement_Sequence --
2435 -----------------------------------------
2437 procedure Traverse_Handled_Statement_Sequence
2438 (N : Node_Id;
2439 D : Dominant_Info := No_Dominant)
2441 Handler : Node_Id;
2443 begin
2444 -- For package bodies without a statement part, the parser adds an empty
2445 -- one, to normalize the representation. The null statement therein,
2446 -- which does not come from source, does not get a SCO.
2448 if Present (N) and then Comes_From_Source (N) then
2449 Traverse_Declarations_Or_Statements (Statements (N), D);
2451 if Present (Exception_Handlers (N)) then
2452 Handler := First_Non_Pragma (Exception_Handlers (N));
2453 while Present (Handler) loop
2454 Traverse_Declarations_Or_Statements
2455 (L => Statements (Handler),
2456 D => ('E', Handler));
2457 Next (Handler);
2458 end loop;
2459 end if;
2460 end if;
2461 end Traverse_Handled_Statement_Sequence;
2463 ---------------------------
2464 -- Traverse_Package_Body --
2465 ---------------------------
2467 procedure Traverse_Package_Body (N : Node_Id) is
2468 Dom : Dominant_Info;
2469 begin
2470 -- The first statement in the handled sequence of statements is
2471 -- dominated by the elaboration of the last declaration.
2473 Dom := Traverse_Declarations_Or_Statements (Declarations (N));
2475 Traverse_Handled_Statement_Sequence
2476 (Handled_Statement_Sequence (N), Dom);
2477 end Traverse_Package_Body;
2479 ----------------------------------
2480 -- Traverse_Package_Declaration --
2481 ----------------------------------
2483 procedure Traverse_Package_Declaration
2484 (N : Node_Id;
2485 D : Dominant_Info := No_Dominant)
2487 Spec : constant Node_Id := Specification (N);
2488 Dom : Dominant_Info;
2490 begin
2491 Dom :=
2492 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D);
2494 -- First private declaration is dominated by last visible declaration
2496 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
2497 end Traverse_Package_Declaration;
2499 ------------------------------
2500 -- Traverse_Sync_Definition --
2501 ------------------------------
2503 procedure Traverse_Sync_Definition (N : Node_Id) is
2504 Dom_Info : Dominant_Info := ('S', N);
2505 -- The first declaration is dominated by the protected or task [type]
2506 -- declaration.
2508 Sync_Def : Node_Id;
2509 -- N's protected or task definition
2511 Priv_Decl : List_Id;
2512 Vis_Decl : List_Id;
2513 -- Sync_Def's Visible_Declarations and Private_Declarations
2515 begin
2516 case Nkind (N) is
2517 when N_Protected_Type_Declaration
2518 | N_Single_Protected_Declaration
2520 Sync_Def := Protected_Definition (N);
2522 when N_Single_Task_Declaration
2523 | N_Task_Type_Declaration
2525 Sync_Def := Task_Definition (N);
2527 when others =>
2528 raise Program_Error;
2529 end case;
2531 -- Sync_Def may be Empty at least for empty Task_Type_Declarations.
2532 -- Querying Visible or Private_Declarations is invalid in this case.
2534 if Present (Sync_Def) then
2535 Vis_Decl := Visible_Declarations (Sync_Def);
2536 Priv_Decl := Private_Declarations (Sync_Def);
2537 else
2538 Vis_Decl := No_List;
2539 Priv_Decl := No_List;
2540 end if;
2542 Dom_Info := Traverse_Declarations_Or_Statements
2543 (L => Vis_Decl,
2544 D => Dom_Info);
2546 -- If visible declarations are present, the first private declaration
2547 -- is dominated by the last visible declaration.
2549 Traverse_Declarations_Or_Statements
2550 (L => Priv_Decl,
2551 D => Dom_Info);
2552 end Traverse_Sync_Definition;
2554 --------------------------------------
2555 -- Traverse_Subprogram_Or_Task_Body --
2556 --------------------------------------
2558 procedure Traverse_Subprogram_Or_Task_Body
2559 (N : Node_Id;
2560 D : Dominant_Info := No_Dominant)
2562 Decls : constant List_Id := Declarations (N);
2563 Dom_Info : Dominant_Info := D;
2565 begin
2566 -- If declarations are present, the first statement is dominated by the
2567 -- last declaration.
2569 Dom_Info := Traverse_Declarations_Or_Statements
2570 (L => Decls, D => Dom_Info);
2572 Traverse_Handled_Statement_Sequence
2573 (N => Handled_Statement_Sequence (N),
2574 D => Dom_Info);
2575 end Traverse_Subprogram_Or_Task_Body;
2577 -------------------------
2578 -- SCO_Record_Filtered --
2579 -------------------------
2581 procedure SCO_Record_Filtered is
2582 type Decision is record
2583 Kind : Character;
2584 -- Type of the SCO decision (see comments for SCO_Table_Entry.C1)
2586 Sloc : Source_Location;
2588 Top : Nat;
2589 -- Index in the SCO_Raw_Table for the root operator/condition for the
2590 -- expression that controls the decision.
2591 end record;
2592 -- Decision descriptor: used to gather information about a candidate
2593 -- SCO decision.
2595 package Pending_Decisions is new Table.Table
2596 (Table_Component_Type => Decision,
2597 Table_Index_Type => Nat,
2598 Table_Low_Bound => 1,
2599 Table_Initial => 1000,
2600 Table_Increment => 200,
2601 Table_Name => "Filter_Pending_Decisions");
2602 -- Table used to hold decisions to process during the collection pass
2604 procedure Add_Expression_Tree (Idx : in out Nat);
2605 -- Add SCO raw table entries for the decision controlling expression
2606 -- tree starting at Idx to the filtered SCO table.
2608 procedure Collect_Decisions
2609 (D : Decision;
2610 Next : out Nat);
2611 -- Collect decisions to add to the filtered SCO table starting at the
2612 -- D decision (including it and its nested operators/conditions). Set
2613 -- Next to the first node index passed the whole decision.
2615 procedure Compute_Range
2616 (Idx : in out Nat;
2617 From : out Source_Location;
2618 To : out Source_Location);
2619 -- Compute the source location range for the expression tree starting at
2620 -- Idx in the SCO raw table. Store its bounds in From and To.
2622 function Is_Decision (Idx : Nat) return Boolean;
2623 -- Return if the expression tree starting at Idx has adjacent nested
2624 -- nodes that make a decision.
2626 procedure Process_Pending_Decisions
2627 (Original_Decision : SCO_Table_Entry);
2628 -- Complete the filtered SCO table using collected decisions. Output
2629 -- decisions inherit the pragma information from the original decision.
2631 procedure Search_Nested_Decisions (Idx : in out Nat);
2632 -- Collect decisions to add to the filtered SCO table starting at the
2633 -- node at Idx in the SCO raw table. This node must not be part of an
2634 -- already-processed decision. Set Idx to the first node index passed
2635 -- the whole expression tree.
2637 procedure Skip_Decision
2638 (Idx : in out Nat;
2639 Process_Nested_Decisions : Boolean);
2640 -- Skip all the nodes that belong to the decision starting at Idx. If
2641 -- Process_Nested_Decision, call Search_Nested_Decisions on the first
2642 -- nested nodes that do not belong to the decision. Set Idx to the first
2643 -- node index passed the whole expression tree.
2645 -------------------------
2646 -- Add_Expression_Tree --
2647 -------------------------
2649 procedure Add_Expression_Tree (Idx : in out Nat) is
2650 Node_Idx : constant Nat := Idx;
2651 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
2652 From : Source_Location;
2653 To : Source_Location;
2655 begin
2656 case T.C1 is
2657 when ' ' =>
2659 -- This is a single condition. Add an entry for it and move on
2661 SCO_Table.Append (T);
2662 Idx := Idx + 1;
2664 when '!' =>
2666 -- This is a NOT operator: add an entry for it and browse its
2667 -- only child.
2669 SCO_Table.Append (T);
2670 Idx := Idx + 1;
2671 Add_Expression_Tree (Idx);
2673 when others =>
2675 -- This must be an AND/OR/AND THEN/OR ELSE operator
2677 if T.C2 = '?' then
2679 -- This is not a short circuit operator: consider this one
2680 -- and all its children as a single condition.
2682 Compute_Range (Idx, From, To);
2683 SCO_Table.Append
2684 ((From => From,
2685 To => To,
2686 C1 => ' ',
2687 C2 => 'c',
2688 Last => False,
2689 Pragma_Sloc => No_Location,
2690 Pragma_Aspect_Name => No_Name));
2692 else
2693 -- This is a real short circuit operator: add an entry for
2694 -- it and browse its children.
2696 SCO_Table.Append (T);
2697 Idx := Idx + 1;
2698 Add_Expression_Tree (Idx);
2699 Add_Expression_Tree (Idx);
2700 end if;
2701 end case;
2702 end Add_Expression_Tree;
2704 -----------------------
2705 -- Collect_Decisions --
2706 -----------------------
2708 procedure Collect_Decisions
2709 (D : Decision;
2710 Next : out Nat)
2712 Idx : Nat := D.Top;
2714 begin
2715 if D.Kind /= 'X' or else Is_Decision (D.Top) then
2716 Pending_Decisions.Append (D);
2717 end if;
2719 Skip_Decision (Idx, True);
2720 Next := Idx;
2721 end Collect_Decisions;
2723 -------------------
2724 -- Compute_Range --
2725 -------------------
2727 procedure Compute_Range
2728 (Idx : in out Nat;
2729 From : out Source_Location;
2730 To : out Source_Location)
2732 Sloc_F : Source_Location := No_Source_Location;
2733 Sloc_T : Source_Location := No_Source_Location;
2735 procedure Process_One;
2736 -- Process one node of the tree, and recurse over children. Update
2737 -- Idx during the traversal.
2739 -----------------
2740 -- Process_One --
2741 -----------------
2743 procedure Process_One is
2744 begin
2745 if Sloc_F = No_Source_Location
2746 or else
2747 SCO_Raw_Table.Table (Idx).From < Sloc_F
2748 then
2749 Sloc_F := SCO_Raw_Table.Table (Idx).From;
2750 end if;
2752 if Sloc_T = No_Source_Location
2753 or else
2754 Sloc_T < SCO_Raw_Table.Table (Idx).To
2755 then
2756 Sloc_T := SCO_Raw_Table.Table (Idx).To;
2757 end if;
2759 if SCO_Raw_Table.Table (Idx).C1 = ' ' then
2761 -- This is a condition: nothing special to do
2763 Idx := Idx + 1;
2765 elsif SCO_Raw_Table.Table (Idx).C1 = '!' then
2767 -- The "not" operator has only one operand
2769 Idx := Idx + 1;
2770 Process_One;
2772 else
2773 -- This is an AND THEN or OR ELSE logical operator: follow the
2774 -- left, then the right operands.
2776 Idx := Idx + 1;
2778 Process_One;
2779 Process_One;
2780 end if;
2781 end Process_One;
2783 -- Start of processing for Compute_Range
2785 begin
2786 Process_One;
2787 From := Sloc_F;
2788 To := Sloc_T;
2789 end Compute_Range;
2791 -----------------
2792 -- Is_Decision --
2793 -----------------
2795 function Is_Decision (Idx : Nat) return Boolean is
2796 Index : Nat := Idx;
2798 begin
2799 loop
2800 declare
2801 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
2803 begin
2804 case T.C1 is
2805 when ' ' =>
2806 return False;
2808 when '!' =>
2810 -- This is a decision iff the only operand of the NOT
2811 -- operator could be a standalone decision.
2813 Index := Idx + 1;
2815 when others =>
2817 -- This node is a logical operator (and thus could be a
2818 -- standalone decision) iff it is a short circuit
2819 -- operator.
2821 return T.C2 /= '?';
2822 end case;
2823 end;
2824 end loop;
2825 end Is_Decision;
2827 -------------------------------
2828 -- Process_Pending_Decisions --
2829 -------------------------------
2831 procedure Process_Pending_Decisions
2832 (Original_Decision : SCO_Table_Entry)
2834 begin
2835 for Index in 1 .. Pending_Decisions.Last loop
2836 declare
2837 D : Decision renames Pending_Decisions.Table (Index);
2838 Idx : Nat := D.Top;
2840 begin
2841 -- Add a SCO table entry for the decision itself
2843 pragma Assert (D.Kind /= ' ');
2845 SCO_Table.Append
2846 ((To => No_Source_Location,
2847 From => D.Sloc,
2848 C1 => D.Kind,
2849 C2 => ' ',
2850 Last => False,
2851 Pragma_Sloc => Original_Decision.Pragma_Sloc,
2852 Pragma_Aspect_Name =>
2853 Original_Decision.Pragma_Aspect_Name));
2855 -- Then add ones for its nested operators/operands. Do not
2856 -- forget to tag its *last* entry as such.
2858 Add_Expression_Tree (Idx);
2859 SCO_Table.Table (SCO_Table.Last).Last := True;
2860 end;
2861 end loop;
2863 -- Clear the pending decisions list
2864 Pending_Decisions.Set_Last (0);
2865 end Process_Pending_Decisions;
2867 -----------------------------
2868 -- Search_Nested_Decisions --
2869 -----------------------------
2871 procedure Search_Nested_Decisions (Idx : in out Nat) is
2872 begin
2873 loop
2874 declare
2875 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2877 begin
2878 case T.C1 is
2879 when ' ' =>
2880 Idx := Idx + 1;
2881 exit;
2883 when '!' =>
2884 Collect_Decisions
2885 ((Kind => 'X',
2886 Sloc => T.From,
2887 Top => Idx),
2888 Idx);
2889 exit;
2891 when others =>
2892 if T.C2 = '?' then
2894 -- This is not a logical operator: start looking for
2895 -- nested decisions from here. Recurse over the left
2896 -- child and let the loop take care of the right one.
2898 Idx := Idx + 1;
2899 Search_Nested_Decisions (Idx);
2901 else
2902 -- We found a nested decision
2904 Collect_Decisions
2905 ((Kind => 'X',
2906 Sloc => T.From,
2907 Top => Idx),
2908 Idx);
2909 exit;
2910 end if;
2911 end case;
2912 end;
2913 end loop;
2914 end Search_Nested_Decisions;
2916 -------------------
2917 -- Skip_Decision --
2918 -------------------
2920 procedure Skip_Decision
2921 (Idx : in out Nat;
2922 Process_Nested_Decisions : Boolean)
2924 begin
2925 loop
2926 declare
2927 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2929 begin
2930 Idx := Idx + 1;
2932 case T.C1 is
2933 when ' ' =>
2934 exit;
2936 when '!' =>
2938 -- This NOT operator belongs to the outside decision:
2939 -- just skip it.
2941 null;
2943 when others =>
2944 if T.C2 = '?' and then Process_Nested_Decisions then
2946 -- This is not a logical operator: start looking for
2947 -- nested decisions from here. Recurse over the left
2948 -- child and let the loop take care of the right one.
2950 Search_Nested_Decisions (Idx);
2952 else
2953 -- This is a logical operator, so it belongs to the
2954 -- outside decision: skip its left child, then let the
2955 -- loop take care of the right one.
2957 Skip_Decision (Idx, Process_Nested_Decisions);
2958 end if;
2959 end case;
2960 end;
2961 end loop;
2962 end Skip_Decision;
2964 -- Start of processing for SCO_Record_Filtered
2966 begin
2967 -- Filtering must happen only once: do nothing if it this pass was
2968 -- already run.
2970 if SCO_Generation_State = Filtered then
2971 return;
2972 else
2973 pragma Assert (SCO_Generation_State = Raw);
2974 SCO_Generation_State := Filtered;
2975 end if;
2977 -- Loop through all SCO entries under SCO units
2979 for Unit_Idx in 1 .. SCO_Unit_Table.Last loop
2980 declare
2981 Unit : SCO_Unit_Table_Entry
2982 renames SCO_Unit_Table.Table (Unit_Idx);
2984 Idx : Nat := Unit.From;
2985 -- Index of the current SCO raw table entry
2987 New_From : constant Nat := SCO_Table.Last + 1;
2988 -- After copying SCO enties of interest to the final table, we
2989 -- will have to change the From/To indexes this unit targets.
2990 -- This constant keeps track of the new From index.
2992 begin
2993 while Idx <= Unit.To loop
2994 declare
2995 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2997 begin
2998 case T.C1 is
3000 -- Decision (of any kind, including pragmas and aspects)
3002 when 'E' | 'G' | 'I' | 'W' | 'X' | 'P' | 'a' | 'A' =>
3003 if SCO_Pragma_Disabled (T.Pragma_Sloc) then
3005 -- Skip SCO entries for decisions in disabled
3006 -- constructs (pragmas or aspects).
3008 Idx := Idx + 1;
3009 Skip_Decision (Idx, False);
3011 else
3012 Collect_Decisions
3013 ((Kind => T.C1,
3014 Sloc => T.From,
3015 Top => Idx + 1),
3016 Idx);
3017 Process_Pending_Decisions (T);
3018 end if;
3020 -- There is no translation/filtering to do for other kind
3021 -- of SCO items (statements, dominance markers, etc.).
3023 when '|' | '&' | '!' | ' ' =>
3025 -- SCO logical operators and conditions cannot exist
3026 -- on their own: they must be inside a decision (such
3027 -- entries must have been skipped by
3028 -- Collect_Decisions).
3030 raise Program_Error;
3032 when others =>
3033 SCO_Table.Append (T);
3034 Idx := Idx + 1;
3035 end case;
3036 end;
3037 end loop;
3039 -- Now, update the SCO entry indexes in the unit entry
3041 Unit.From := New_From;
3042 Unit.To := SCO_Table.Last;
3043 end;
3044 end loop;
3046 -- Then clear the raw table to free bytes
3048 SCO_Raw_Table.Free;
3049 end SCO_Record_Filtered;
3051 end Par_SCO;