?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merged revisions 208012,208018-208019,208021,208023-208030,208033,208037,208040-20804...
[official-gcc.git] / main / gcc / ada / par_sco.adb
blob97b6f93e4c5afd4783fec15f8d619f56906ab186
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-2013, 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
48 package body Par_SCO is
49
50 -----------------------
51 -- Unit Number Table --
52 -----------------------
53
54 -- This table parallels the SCO_Unit_Table, keeping track of the unit
55 -- numbers corresponding to the entries made in this table, so that before
56 -- writing out the SCO information to the ALI file, we can fill in the
57 -- proper dependency numbers and file names.
58
59 -- Note that the zero'th entry is here for convenience in sorting the
60 -- table, the real lower bound is 1.
61
62 package SCO_Unit_Number_Table is new Table.Table (
63 Table_Component_Type => Unit_Number_Type,
64 Table_Index_Type => SCO_Unit_Index,
65 Table_Low_Bound => 0, -- see note above on sort
66 Table_Initial => 20,
67 Table_Increment => 200,
68 Table_Name => "SCO_Unit_Number_Entry");
69
70 ---------------------------------
71 -- Condition/Pragma Hash Table --
72 ---------------------------------
73
74 -- We need to be able to get to conditions quickly for handling the calls
75 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
76 -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the
77 -- conditions and pragmas in the table by their starting sloc, and use this
78 -- hash table to map from these sloc values to SCO_Table indexes.
79
80 type Header_Num is new Integer range 0 .. 996;
81 -- Type for hash table headers
82
83 function Hash (F : Source_Ptr) return Header_Num;
84 -- Function to Hash source pointer value
85
86 function Equal (F1, F2 : Source_Ptr) return Boolean;
87 -- Function to test two keys for equality
88
89 package Condition_Pragma_Hash_Table is new Simple_HTable
90 (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
91 -- The actual hash table
92
93 --------------------------
94 -- Internal Subprograms --
95 --------------------------
96
97 function Has_Decision (N : Node_Id) return Boolean;
98 -- N is the node for a subexpression. Returns True if the subexpression
99 -- contains a nested decision (i.e. either is a logical operator, or
100 -- contains a logical operator in its subtree).
101
102 function Is_Logical_Operator (N : Node_Id) return Boolean;
103 -- N is the node for a subexpression. This procedure just tests N to see
104 -- if it is a logical operator (including short circuit conditions, but
105 -- excluding OR and AND) and returns True if so, False otherwise, it does
106 -- no other processing.
107
108 function To_Source_Location (S : Source_Ptr) return Source_Location;
109 -- Converts Source_Ptr value to Source_Location (line/col) format
110
111 procedure Process_Decisions
112 (N : Node_Id;
113 T : Character;
114 Pragma_Sloc : Source_Ptr);
115 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
116 -- to output any decisions it contains. T is one of IEGPWX (for context of
117 -- expression: if/exit when/entry guard/pragma/while/expression). If T is
118 -- other than X, the node N is the if expression involved, and a decision
119 -- is always present (at the very least a simple decision is present at the
120 -- top level).
121
122 procedure Process_Decisions
123 (L : List_Id;
124 T : Character;
125 Pragma_Sloc : Source_Ptr);
126 -- Calls above procedure for each element of the list L
127
128 procedure Set_Table_Entry
129 (C1 : Character;
130 C2 : Character;
131 From : Source_Ptr;
132 To : Source_Ptr;
133 Last : Boolean;
134 Pragma_Sloc : Source_Ptr := No_Location;
135 Pragma_Aspect_Name : Name_Id := No_Name);
136 -- Append an entry to SCO_Table with fields set as per arguments
137
138 type Dominant_Info is record
139 K : Character;
140 -- F/T/S/E for a valid dominance marker, or ' ' for no dominant
141
142 N : Node_Id;
143 -- Node providing the Sloc(s) for the dominance marker
144 end record;
145 No_Dominant : constant Dominant_Info := (' ', Empty);
146
147 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr);
148 -- Add one entry from the instance table to the corresponding SCO table
149
150 procedure Traverse_Declarations_Or_Statements
151 (L : List_Id;
152 D : Dominant_Info := No_Dominant;
153 P : Node_Id := Empty);
154 -- Process L, a list of statements or declarations dominated by D.
155 -- If P is present, it is processed as though it had been prepended to L.
156
157 function Traverse_Declarations_Or_Statements
158 (L : List_Id;
159 D : Dominant_Info := No_Dominant;
160 P : Node_Id := Empty) return Dominant_Info;
161 -- Same as above, and returns dominant information corresponding to the
162 -- last node with SCO in L.
163
164 -- The following Traverse_* routines perform appropriate calls to
165 -- Traverse_Declarations_Or_Statements to traverse specific node kinds.
166 -- Parameter D, when present, indicates the dominant of the first
167 -- declaration or statement within N.
168
169 -- Why is Traverse_Sync_Definition commented specificaly and
170 -- the others are not???
171
172 procedure Traverse_Generic_Package_Declaration (N : Node_Id);
173 procedure Traverse_Handled_Statement_Sequence
174 (N : Node_Id;
175 D : Dominant_Info := No_Dominant);
176 procedure Traverse_Package_Body (N : Node_Id);
177 procedure Traverse_Package_Declaration
178 (N : Node_Id;
179 D : Dominant_Info := No_Dominant);
180 procedure Traverse_Subprogram_Or_Task_Body
181 (N : Node_Id;
182 D : Dominant_Info := No_Dominant);
183
184 procedure Traverse_Sync_Definition (N : Node_Id);
185 -- Traverse a protected definition or task definition
186
187 procedure Write_SCOs_To_ALI_File is new Put_SCOs;
188 -- Write SCO information to the ALI file using routines in Lib.Util
189
190 ----------
191 -- dsco --
192 ----------
193
194 procedure dsco is
195 begin
196 -- Dump SCO unit table
197
198 Write_Line ("SCO Unit Table");
199 Write_Line ("--------------");
200
201 for Index in 1 .. SCO_Unit_Table.Last loop
202 declare
203 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
204
205 begin
206 Write_Str (" ");
207 Write_Int (Int (Index));
208 Write_Str (". Dep_Num = ");
209 Write_Int (Int (UTE.Dep_Num));
210 Write_Str (" From = ");
211 Write_Int (Int (UTE.From));
212 Write_Str (" To = ");
213 Write_Int (Int (UTE.To));
214
215 Write_Str (" File_Name = """);
216
217 if UTE.File_Name /= null then
218 Write_Str (UTE.File_Name.all);
219 end if;
220
221 Write_Char ('"');
222 Write_Eol;
223 end;
224 end loop;
225
226 -- Dump SCO Unit number table if it contains any entries
227
228 if SCO_Unit_Number_Table.Last >= 1 then
229 Write_Eol;
230 Write_Line ("SCO Unit Number Table");
231 Write_Line ("---------------------");
232
233 for Index in 1 .. SCO_Unit_Number_Table.Last loop
234 Write_Str (" ");
235 Write_Int (Int (Index));
236 Write_Str (". Unit_Number = ");
237 Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
238 Write_Eol;
239 end loop;
240 end if;
241
242 -- Dump SCO table itself
243
244 Write_Eol;
245 Write_Line ("SCO Table");
246 Write_Line ("---------");
247
248 for Index in 1 .. SCO_Table.Last loop
249 declare
250 T : SCO_Table_Entry renames SCO_Table.Table (Index);
251
252 begin
253 Write_Str (" ");
254 Write_Int (Index);
255 Write_Char ('.');
256
257 if T.C1 /= ' ' then
258 Write_Str (" C1 = '");
259 Write_Char (T.C1);
260 Write_Char (''');
261 end if;
262
263 if T.C2 /= ' ' then
264 Write_Str (" C2 = '");
265 Write_Char (T.C2);
266 Write_Char (''');
267 end if;
268
269 if T.From /= No_Source_Location then
270 Write_Str (" From = ");
271 Write_Int (Int (T.From.Line));
272 Write_Char (':');
273 Write_Int (Int (T.From.Col));
274 end if;
275
276 if T.To /= No_Source_Location then
277 Write_Str (" To = ");
278 Write_Int (Int (T.To.Line));
279 Write_Char (':');
280 Write_Int (Int (T.To.Col));
281 end if;
282
283 if T.Last then
284 Write_Str (" True");
285 else
286 Write_Str (" False");
287 end if;
288
289 Write_Eol;
290 end;
291 end loop;
292 end dsco;
293
294 -----------
295 -- Equal --
296 -----------
297
298 function Equal (F1, F2 : Source_Ptr) return Boolean is
299 begin
300 return F1 = F2;
301 end Equal;
302
303 ------------------
304 -- Has_Decision --
305 ------------------
306
307 function Has_Decision (N : Node_Id) return Boolean is
308
309 function Check_Node (N : Node_Id) return Traverse_Result;
310
311 ----------------
312 -- Check_Node --
313 ----------------
314
315 function Check_Node (N : Node_Id) return Traverse_Result is
316 begin
317 if Is_Logical_Operator (N) then
318 return Abandon;
319 else
320 return OK;
321 end if;
322 end Check_Node;
323
324 function Traverse is new Traverse_Func (Check_Node);
325
326 -- Start of processing for Has_Decision
327
328 begin
329 return Traverse (N) = Abandon;
330 end Has_Decision;
331
332 ----------
333 -- Hash --
334 ----------
335
336 function Hash (F : Source_Ptr) return Header_Num is
337 begin
338 return Header_Num (Nat (F) mod 997);
339 end Hash;
340
341 ----------------
342 -- Initialize --
343 ----------------
344
345 procedure Initialize is
346 begin
347 SCO_Unit_Number_Table.Init;
348
349 -- Set dummy 0'th entry in place for sort
350
351 SCO_Unit_Number_Table.Increment_Last;
352 end Initialize;
353
354 -------------------------
355 -- Is_Logical_Operator --
356 -------------------------
357
358 function Is_Logical_Operator (N : Node_Id) return Boolean is
359 begin
360 return Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else);
361 end Is_Logical_Operator;
362
363 -----------------------
364 -- Process_Decisions --
365 -----------------------
366
367 -- Version taking a list
368
369 procedure Process_Decisions
370 (L : List_Id;
371 T : Character;
372 Pragma_Sloc : Source_Ptr)
373 is
374 N : Node_Id;
375 begin
376 if L /= No_List then
377 N := First (L);
378 while Present (N) loop
379 Process_Decisions (N, T, Pragma_Sloc);
380 Next (N);
381 end loop;
382 end if;
383 end Process_Decisions;
384
385 -- Version taking a node
386
387 Current_Pragma_Sloc : Source_Ptr := No_Location;
388 -- While processing a pragma, this is set to the sloc of the N_Pragma node
389
390 procedure Process_Decisions
391 (N : Node_Id;
392 T : Character;
393 Pragma_Sloc : Source_Ptr)
394 is
395 Mark : Nat;
396 -- This is used to mark the location of a decision sequence in the SCO
397 -- table. We use it for backing out a simple decision in an expression
398 -- context that contains only NOT operators.
399
400 X_Not_Decision : Boolean;
401 -- This flag keeps track of whether a decision sequence in the SCO table
402 -- contains only NOT operators, and is for an expression context (T=X).
403 -- The flag will be set False if T is other than X, or if an operator
404 -- other than NOT is in the sequence.
405
406 function Process_Node (N : Node_Id) return Traverse_Result;
407 -- Processes one node in the traversal, looking for logical operators,
408 -- and if one is found, outputs the appropriate table entries.
409
410 procedure Output_Decision_Operand (N : Node_Id);
411 -- The node N is the top level logical operator of a decision, or it is
412 -- one of the operands of a logical operator belonging to a single
413 -- complex decision. This routine outputs the sequence of table entries
414 -- corresponding to the node. Note that we do not process the sub-
415 -- operands to look for further decisions, that processing is done in
416 -- Process_Decision_Operand, because we can't get decisions mixed up in
417 -- the global table. Call has no effect if N is Empty.
418
419 procedure Output_Element (N : Node_Id);
420 -- Node N is an operand of a logical operator that is not itself a
421 -- logical operator, or it is a simple decision. This routine outputs
422 -- the table entry for the element, with C1 set to ' '. Last is set
423 -- False, and an entry is made in the condition hash table.
424
425 procedure Output_Header (T : Character);
426 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
427 -- PRAGMA, and 'X' for the expression case.
428
429 procedure Process_Decision_Operand (N : Node_Id);
430 -- This is called on node N, the top level node of a decision, or on one
431 -- of its operands or suboperands after generating the full output for
432 -- the complex decision. It process the suboperands of the decision
433 -- looking for nested decisions.
434
435 -----------------------------
436 -- Output_Decision_Operand --
437 -----------------------------
438
439 procedure Output_Decision_Operand (N : Node_Id) is
440 C : Character;
441 L : Node_Id;
442
443 begin
444 if No (N) then
445 return;
446
447 -- Logical operator
448
449 elsif Is_Logical_Operator (N) then
450 if Nkind (N) = N_Op_Not then
451 C := '!';
452 L := Empty;
453
454 else
455 L := Left_Opnd (N);
456
457 if Nkind_In (N, N_Op_Or, N_Or_Else) then
458 C := '|';
459 else
460 C := '&';
461 end if;
462 end if;
463
464 Set_Table_Entry
465 (C1 => C,
466 C2 => ' ',
467 From => Sloc (N),
468 To => No_Location,
469 Last => False);
470
471 Output_Decision_Operand (L);
472 Output_Decision_Operand (Right_Opnd (N));
473
474 -- Not a logical operator
475
476 else
477 Output_Element (N);
478 end if;
479 end Output_Decision_Operand;
480
481 --------------------
482 -- Output_Element --
483 --------------------
484
485 procedure Output_Element (N : Node_Id) is
486 FSloc : Source_Ptr;
487 LSloc : Source_Ptr;
488 begin
489 Sloc_Range (N, FSloc, LSloc);
490 Set_Table_Entry
491 (C1 => ' ',
492 C2 => 'c',
493 From => FSloc,
494 To => LSloc,
495 Last => False);
496 Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last);
497 end Output_Element;
498
499 -------------------
500 -- Output_Header --
501 -------------------
502
503 procedure Output_Header (T : Character) is
504 Loc : Source_Ptr := No_Location;
505 -- Node whose Sloc is used for the decision
506
507 Nam : Name_Id := No_Name;
508 -- For the case of an aspect, aspect name
509
510 begin
511 case T is
512 when 'I' | 'E' | 'W' | 'a' | 'A' =>
513
514 -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of
515 -- the parent of the expression.
516
517 Loc := Sloc (Parent (N));
518
519 if T = 'a' or else T = 'A' then
520 Nam := Chars (Identifier (Parent (N)));
521 end if;
522
523 when 'G' | 'P' =>
524
525 -- For entry guard, the token sloc is from the N_Entry_Body.
526 -- For PRAGMA, we must get the location from the pragma node.
527 -- Argument N is the pragma argument, and we have to go up
528 -- two levels (through the pragma argument association) to
529 -- get to the pragma node itself. For the guard on a select
530 -- alternative, we do not have access to the token location for
531 -- the WHEN, so we use the first sloc of the condition itself
532 -- (note: we use First_Sloc, not Sloc, because this is what is
533 -- referenced by dominance markers).
534
535 -- Doesn't this requirement of using First_Sloc need to be
536 -- documented in the spec ???
537
538 if Nkind_In (Parent (N), N_Accept_Alternative,
539 N_Delay_Alternative,
540 N_Terminate_Alternative)
541 then
542 Loc := First_Sloc (N);
543 else
544 Loc := Sloc (Parent (Parent (N)));
545 end if;
546
547 when 'X' =>
548
549 -- For an expression, no Sloc
550
551 null;
552
553 -- No other possibilities
554
555 when others =>
556 raise Program_Error;
557 end case;
558
559 Set_Table_Entry
560 (C1 => T,
561 C2 => ' ',
562 From => Loc,
563 To => No_Location,
564 Last => False,
565 Pragma_Sloc => Pragma_Sloc,
566 Pragma_Aspect_Name => Nam);
567
568 -- For an aspect specification, which will be rewritten into a
569 -- pragma, enter a hash table entry now.
570
571 if T = 'a' then
572 Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
573 end if;
574 end Output_Header;
575
576 ------------------------------
577 -- Process_Decision_Operand --
578 ------------------------------
579
580 procedure Process_Decision_Operand (N : Node_Id) is
581 begin
582 if Is_Logical_Operator (N) then
583 if Nkind (N) /= N_Op_Not then
584 Process_Decision_Operand (Left_Opnd (N));
585 X_Not_Decision := False;
586 end if;
587
588 Process_Decision_Operand (Right_Opnd (N));
589
590 else
591 Process_Decisions (N, 'X', Pragma_Sloc);
592 end if;
593 end Process_Decision_Operand;
594
595 ------------------
596 -- Process_Node --
597 ------------------
598
599 function Process_Node (N : Node_Id) return Traverse_Result is
600 begin
601 case Nkind (N) is
602
603 -- Logical operators, output table entries and then process
604 -- operands recursively to deal with nested conditions.
605
606 when N_And_Then | N_Or_Else | N_Op_Not =>
607 declare
608 T : Character;
609
610 begin
611 -- If outer level, then type comes from call, otherwise it
612 -- is more deeply nested and counts as X for expression.
613
614 if N = Process_Decisions.N then
615 T := Process_Decisions.T;
616 else
617 T := 'X';
618 end if;
619
620 -- Output header for sequence
621
622 X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
623 Mark := SCO_Table.Last;
624 Output_Header (T);
625
626 -- Output the decision
627
628 Output_Decision_Operand (N);
629
630 -- If the decision was in an expression context (T = 'X')
631 -- and contained only NOT operators, then we don't output
632 -- it, so delete it.
633
634 if X_Not_Decision then
635 SCO_Table.Set_Last (Mark);
636
637 -- Otherwise, set Last in last table entry to mark end
638
639 else
640 SCO_Table.Table (SCO_Table.Last).Last := True;
641 end if;
642
643 -- Process any embedded decisions
644
645 Process_Decision_Operand (N);
646 return Skip;
647 end;
648
649 -- Case expression
650
651 -- Really hard to believe this is correct given the special
652 -- handling for if expressions below ???
653
654 when N_Case_Expression =>
655 return OK; -- ???
656
657 -- If expression, processed like an if statement
658
659 when N_If_Expression =>
660 declare
661 Cond : constant Node_Id := First (Expressions (N));
662 Thnx : constant Node_Id := Next (Cond);
663 Elsx : constant Node_Id := Next (Thnx);
664 begin
665 Process_Decisions (Cond, 'I', Pragma_Sloc);
666 Process_Decisions (Thnx, 'X', Pragma_Sloc);
667 Process_Decisions (Elsx, 'X', Pragma_Sloc);
668 return Skip;
669 end;
670
671 -- All other cases, continue scan
672
673 when others =>
674 return OK;
675
676 end case;
677 end Process_Node;
678
679 procedure Traverse is new Traverse_Proc (Process_Node);
680
681 -- Start of processing for Process_Decisions
682
683 begin
684 if No (N) then
685 return;
686 end if;
687
688 -- See if we have simple decision at outer level and if so then
689 -- generate the decision entry for this simple decision. A simple
690 -- decision is a boolean expression (which is not a logical operator
691 -- or short circuit form) appearing as the operand of an IF, WHILE,
692 -- EXIT WHEN, or special PRAGMA construct.
693
694 if T /= 'X' and then not Is_Logical_Operator (N) then
695 Output_Header (T);
696 Output_Element (N);
697
698 -- Change Last in last table entry to True to mark end of
699 -- sequence, which is this case is only one element long.
700
701 SCO_Table.Table (SCO_Table.Last).Last := True;
702 end if;
703
704 Traverse (N);
705 end Process_Decisions;
706
707 -----------
708 -- pscos --
709 -----------
710
711 procedure pscos is
712
713 procedure Write_Info_Char (C : Character) renames Write_Char;
714 -- Write one character;
715
716 procedure Write_Info_Initiate (Key : Character) renames Write_Char;
717 -- Start new one and write one character;
718
719 procedure Write_Info_Nat (N : Nat);
720 -- Write value of N
721
722 procedure Write_Info_Terminate renames Write_Eol;
723 -- Terminate current line
724
725 --------------------
726 -- Write_Info_Nat --
727 --------------------
728
729 procedure Write_Info_Nat (N : Nat) is
730 begin
731 Write_Int (N);
732 end Write_Info_Nat;
733
734 procedure Debug_Put_SCOs is new Put_SCOs;
735
736 -- Start of processing for pscos
737
738 begin
739 Debug_Put_SCOs;
740 end pscos;
741
742 ---------------------
743 -- Record_Instance --
744 ---------------------
745
746 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is
747 Inst_Src : constant Source_File_Index :=
748 Get_Source_File_Index (Inst_Sloc);
749 begin
750 SCO_Instance_Table.Append
751 ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)),
752 Inst_Loc => To_Source_Location (Inst_Sloc),
753 Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src))));
754 pragma Assert
755 (SCO_Instance_Table.Last = SCO_Instance_Index (Id));
756 end Record_Instance;
757
758 ----------------
759 -- SCO_Output --
760 ----------------
761
762 procedure SCO_Output is
763 procedure Populate_SCO_Instance_Table is
764 new Sinput.Iterate_On_Instances (Record_Instance);
765
766 SCO_Index : Nat;
767
768 begin
769 if Debug_Flag_Dot_OO then
770 dsco;
771 end if;
772
773 Populate_SCO_Instance_Table;
774
775 -- Sort the unit tables based on dependency numbers
776
777 Unit_Table_Sort : declare
778
779 function Lt (Op1, Op2 : Natural) return Boolean;
780 -- Comparison routine for sort call
781
782 procedure Move (From : Natural; To : Natural);
783 -- Move routine for sort call
784
785 --------
786 -- Lt --
787 --------
788
789 function Lt (Op1, Op2 : Natural) return Boolean is
790 begin
791 return
792 Dependency_Num
793 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
794 <
795 Dependency_Num
796 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
797 end Lt;
798
799 ----------
800 -- Move --
801 ----------
802
803 procedure Move (From : Natural; To : Natural) is
804 begin
805 SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
806 SCO_Unit_Table.Table (SCO_Unit_Index (From));
807 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
808 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
809 end Move;
810
811 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
812
813 -- Start of processing for Unit_Table_Sort
814
815 begin
816 Sorting.Sort (Integer (SCO_Unit_Table.Last));
817 end Unit_Table_Sort;
818
819 -- Loop through entries in the unit table to set file name and
820 -- dependency number entries.
821
822 for J in 1 .. SCO_Unit_Table.Last loop
823 declare
824 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
825 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
826 begin
827 Get_Name_String (Reference_Name (Source_Index (U)));
828 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
829 UTE.Dep_Num := Dependency_Num (U);
830 end;
831 end loop;
832
833 -- Stamp out SCO entries for decisions in disabled constructs (pragmas
834 -- or aspects).
835
836 SCO_Index := 1;
837 while SCO_Index <= SCO_Table.Last loop
838 if Is_Decision (SCO_Table.Table (SCO_Index).C1)
839 and then SCO_Pragma_Disabled
840 (SCO_Table.Table (SCO_Index).Pragma_Sloc)
841 then
842 loop
843 SCO_Table.Table (SCO_Index).C1 := ASCII.NUL;
844 exit when SCO_Table.Table (SCO_Index).Last;
845 SCO_Index := SCO_Index + 1;
846 end loop;
847 end if;
848
849 SCO_Index := SCO_Index + 1;
850 end loop;
851
852 -- Now the tables are all setup for output to the ALI file
853
854 Write_SCOs_To_ALI_File;
855 end SCO_Output;
856
857 -------------------------
858 -- SCO_Pragma_Disabled --
859 -------------------------
860
861 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
862 Index : Nat;
863
864 begin
865 if Loc = No_Location then
866 return False;
867 end if;
868
869 Index := Condition_Pragma_Hash_Table.Get (Loc);
870
871 -- The test here for zero is to deal with possible previous errors, and
872 -- for the case of pragma statement SCOs, for which we always set the
873 -- Pragma_Sloc even if the particular pragma cannot be specifically
874 -- disabled.
875
876 if Index /= 0 then
877 declare
878 T : SCO_Table_Entry renames SCO_Table.Table (Index);
879 begin
880 case T.C1 is
881 when 'S' =>
882 -- Pragma statement
883
884 return T.C2 = 'p';
885
886 when 'A' =>
887 -- Aspect decision (enabled)
888
889 return False;
890
891 when 'a' =>
892 -- Aspect decision (not enabled)
893
894 return True;
895
896 when ASCII.NUL =>
897 -- Nullified disabled SCO
898
899 return True;
900
901 when others =>
902 raise Program_Error;
903 end case;
904 end;
905
906 else
907 return False;
908 end if;
909 end SCO_Pragma_Disabled;
910
911 ----------------
912 -- SCO_Record --
913 ----------------
914
915 procedure SCO_Record (U : Unit_Number_Type) is
916 Lu : Node_Id;
917 From : Nat;
918
919 procedure Traverse_Aux_Decls (N : Node_Id);
920 -- Traverse the Aux_Decls_Node of compilation unit N
921
922 ------------------------
923 -- Traverse_Aux_Decls --
924 ------------------------
925
926 procedure Traverse_Aux_Decls (N : Node_Id) is
927 ADN : constant Node_Id := Aux_Decls_Node (N);
928 begin
929 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
930 Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
931
932 -- Declarations and Actions do not correspond to source constructs,
933 -- they contain only nodes from expansion, so at this point they
934 -- should still be empty:
935
936 pragma Assert (No (Declarations (ADN)));
937 pragma Assert (No (Actions (ADN)));
938 end Traverse_Aux_Decls;
939
940 -- Start of processing for SCO_Record
941
942 begin
943 -- Ignore call if not generating code and generating SCO's
944
945 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
946 return;
947 end if;
948
949 -- Ignore call if this unit already recorded
950
951 for J in 1 .. SCO_Unit_Number_Table.Last loop
952 if U = SCO_Unit_Number_Table.Table (J) then
953 return;
954 end if;
955 end loop;
956
957 -- Otherwise record starting entry
958
959 From := SCO_Table.Last + 1;
960
961 -- Get Unit (checking case of subunit)
962
963 Lu := Unit (Cunit (U));
964
965 if Nkind (Lu) = N_Subunit then
966 Lu := Proper_Body (Lu);
967 end if;
968
969 -- Traverse the unit
970
971 Traverse_Aux_Decls (Cunit (U));
972
973 case Nkind (Lu) is
974 when
975 N_Package_Declaration |
976 N_Package_Body |
977 N_Subprogram_Declaration |
978 N_Subprogram_Body |
979 N_Generic_Package_Declaration |
980 N_Protected_Body |
981 N_Task_Body |
982 N_Generic_Instantiation =>
983
984 Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
985
986 when others =>
987
988 -- All other cases of compilation units (e.g. renamings), generate
989 -- no SCO information.
990
991 null;
992 end case;
993
994 -- Make entry for new unit in unit tables, we will fill in the file
995 -- name and dependency numbers later.
996
997 SCO_Unit_Table.Append (
998 (Dep_Num => 0,
999 File_Name => null,
1000 From => From,
1001 To => SCO_Table.Last));
1002
1003 SCO_Unit_Number_Table.Append (U);
1004 end SCO_Record;
1005
1006 -----------------------
1007 -- Set_SCO_Condition --
1008 -----------------------
1009
1010 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
1011 Orig : constant Node_Id := Original_Node (Cond);
1012 Index : Nat;
1013 Start : Source_Ptr;
1014 Dummy : Source_Ptr;
1015
1016 Constant_Condition_Code : constant array (Boolean) of Character :=
1017 (False => 'f', True => 't');
1018 begin
1019 Sloc_Range (Orig, Start, Dummy);
1020 Index := Condition_Pragma_Hash_Table.Get (Start);
1021
1022 -- Index can be zero for boolean expressions that do not have SCOs
1023 -- (simple decisions outside of a control flow structure), or in case
1024 -- of a previous error.
1025
1026 if Index = 0 then
1027 return;
1028
1029 else
1030 pragma Assert (SCO_Table.Table (Index).C1 = ' ');
1031 SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val);
1032 end if;
1033 end Set_SCO_Condition;
1034
1035 ----------------------------
1036 -- Set_SCO_Pragma_Enabled --
1037 ----------------------------
1038
1039 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
1040 Index : Nat;
1041
1042 begin
1043 -- Nothing to do if not generating SCO, or if we're not processing the
1044 -- original source occurrence of the pragma.
1045
1046 if not (Generate_SCO
1047 and then In_Extended_Main_Source_Unit (Loc)
1048 and then not (In_Instance or In_Inlined_Body))
1049 then
1050 return;
1051 end if;
1052
1053 -- Note: the reason we use the Sloc value as the key is that in the
1054 -- generic case, the call to this procedure is made on a copy of the
1055 -- original node, so we can't use the Node_Id value.
1056
1057 Index := Condition_Pragma_Hash_Table.Get (Loc);
1058
1059 -- A zero index here indicates that semantic analysis found an
1060 -- activated pragma at Loc which does not have a corresponding pragma
1061 -- or aspect at the syntax level. This may occur in legitimate cases
1062 -- because of expanded code (such are Pre/Post conditions generated for
1063 -- formal parameter validity checks), or as a consequence of a previous
1064 -- error.
1065
1066 if Index = 0 then
1067 return;
1068
1069 else
1070 declare
1071 T : SCO_Table_Entry renames SCO_Table.Table (Index);
1072
1073 begin
1074 -- Note: may be called multiple times for the same sloc, so
1075 -- account for the fact that the entry may already have been
1076 -- marked enabled.
1077
1078 case T.C1 is
1079 -- Aspect (decision SCO)
1080
1081 when 'a' =>
1082 T.C1 := 'A';
1083
1084 when 'A' =>
1085 null;
1086
1087 -- Pragma (statement SCO)
1088
1089 when 'S' =>
1090 pragma Assert (T.C2 = 'p' or else T.C2 = 'P');
1091 T.C2 := 'P';
1092
1093 when others =>
1094 raise Program_Error;
1095 end case;
1096 end;
1097 end if;
1098 end Set_SCO_Pragma_Enabled;
1099
1100 ---------------------
1101 -- Set_Table_Entry --
1102 ---------------------
1103
1104 procedure Set_Table_Entry
1105 (C1 : Character;
1106 C2 : Character;
1107 From : Source_Ptr;
1108 To : Source_Ptr;
1109 Last : Boolean;
1110 Pragma_Sloc : Source_Ptr := No_Location;
1111 Pragma_Aspect_Name : Name_Id := No_Name)
1112 is
1113 begin
1114 SCO_Table.Append
1115 ((C1 => C1,
1116 C2 => C2,
1117 From => To_Source_Location (From),
1118 To => To_Source_Location (To),
1119 Last => Last,
1120 Pragma_Sloc => Pragma_Sloc,
1121 Pragma_Aspect_Name => Pragma_Aspect_Name));
1122 end Set_Table_Entry;
1123
1124 ------------------------
1125 -- To_Source_Location --
1126 ------------------------
1127
1128 function To_Source_Location (S : Source_Ptr) return Source_Location is
1129 begin
1130 if S = No_Location then
1131 return No_Source_Location;
1132 else
1133 return
1134 (Line => Get_Logical_Line_Number (S),
1135 Col => Get_Column_Number (S));
1136 end if;
1137 end To_Source_Location;
1138
1139 -----------------------------------------
1140 -- Traverse_Declarations_Or_Statements --
1141 -----------------------------------------
1142
1143 -- Tables used by Traverse_Declarations_Or_Statements for temporarily
1144 -- holding statement and decision entries. These are declared globally
1145 -- since they are shared by recursive calls to this procedure.
1146
1147 type SC_Entry is record
1148 N : Node_Id;
1149 From : Source_Ptr;
1150 To : Source_Ptr;
1151 Typ : Character;
1152 end record;
1153 -- Used to store a single entry in the following table, From:To represents
1154 -- the range of entries in the CS line entry, and typ is the type, with
1155 -- space meaning that no type letter will accompany the entry.
1156
1157 package SC is new Table.Table (
1158 Table_Component_Type => SC_Entry,
1159 Table_Index_Type => Nat,
1160 Table_Low_Bound => 1,
1161 Table_Initial => 1000,
1162 Table_Increment => 200,
1163 Table_Name => "SCO_SC");
1164 -- Used to store statement components for a CS entry to be output
1165 -- as a result of the call to this procedure. SC.Last is the last
1166 -- entry stored, so the current statement sequence is represented
1167 -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on
1168 -- entry to each recursive call to the routine.
1169 --
1170 -- Extend_Statement_Sequence adds an entry to this array, and then
1171 -- Set_Statement_Entry clears the entries starting with SC_First,
1172 -- copying these entries to the main SCO output table. The reason that
1173 -- we do the temporary caching of results in this array is that we want
1174 -- the SCO table entries for a given CS line to be contiguous, and the
1175 -- processing may output intermediate entries such as decision entries.
1176
1177 type SD_Entry is record
1178 Nod : Node_Id;
1179 Lst : List_Id;
1180 Typ : Character;
1181 Plo : Source_Ptr;
1182 end record;
1183 -- Used to store a single entry in the following table. Nod is the node to
1184 -- be searched for decisions for the case of Process_Decisions_Defer with a
1185 -- node argument (with Lst set to No_List. Lst is the list to be searched
1186 -- for decisions for the case of Process_Decisions_Defer with a List
1187 -- argument (in which case Nod is set to Empty). Plo is the sloc of the
1188 -- enclosing pragma, if any.
1189
1190 package SD is new Table.Table (
1191 Table_Component_Type => SD_Entry,
1192 Table_Index_Type => Nat,
1193 Table_Low_Bound => 1,
1194 Table_Initial => 1000,
1195 Table_Increment => 200,
1196 Table_Name => "SCO_SD");
1197 -- Used to store possible decision information. Instead of calling the
1198 -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
1199 -- which simply stores the arguments in this table. Then when we clear
1200 -- out a statement sequence using Set_Statement_Entry, after generating
1201 -- the CS lines for the statements, the entries in this table result in
1202 -- calls to Process_Decision. The reason for doing things this way is to
1203 -- ensure that decisions are output after the CS line for the statements
1204 -- in which the decisions occur.
1205
1206 procedure Traverse_Declarations_Or_Statements
1207 (L : List_Id;
1208 D : Dominant_Info := No_Dominant;
1209 P : Node_Id := Empty)
1210 is
1211 Discard_Dom : Dominant_Info;
1212 pragma Warnings (Off, Discard_Dom);
1213 begin
1214 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P);
1215 end Traverse_Declarations_Or_Statements;
1216
1217 function Traverse_Declarations_Or_Statements
1218 (L : List_Id;
1219 D : Dominant_Info := No_Dominant;
1220 P : Node_Id := Empty) return Dominant_Info
1221 is
1222 Current_Dominant : Dominant_Info := D;
1223 -- Dominance information for the current basic block
1224
1225 Current_Test : Node_Id;
1226 -- Conditional node (N_If_Statement or N_Elsiif being processed
1227
1228 N : Node_Id;
1229
1230 SC_First : constant Nat := SC.Last + 1;
1231 SD_First : constant Nat := SD.Last + 1;
1232 -- Record first entries used in SC/SD at this recursive level
1233
1234 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
1235 -- Extend the current statement sequence to encompass the node N. Typ
1236 -- is the letter that identifies the type of statement/declaration that
1237 -- is being added to the sequence.
1238
1239 procedure Set_Statement_Entry;
1240 -- Output CS entries for all statements saved in table SC, and end the
1241 -- current CS sequence. Then output entries for all decisions nested in
1242 -- these statements, which have been deferred so far.
1243
1244 procedure Process_Decisions_Defer (N : Node_Id; T : Character);
1245 pragma Inline (Process_Decisions_Defer);
1246 -- This routine is logically the same as Process_Decisions, except that
1247 -- the arguments are saved in the SD table for later processing when
1248 -- Set_Statement_Entry is called, which goes through the saved entries
1249 -- making the corresponding calls to Process_Decision.
1250
1251 procedure Process_Decisions_Defer (L : List_Id; T : Character);
1252 pragma Inline (Process_Decisions_Defer);
1253 -- Same case for list arguments, deferred call to Process_Decisions
1254
1255 procedure Traverse_One (N : Node_Id);
1256 -- Traverse one declaration or statement
1257
1258 procedure Traverse_Aspects (N : Node_Id);
1259 -- Helper for Traverse_One: traverse N's aspect specifications
1260
1261 -------------------------
1262 -- Set_Statement_Entry --
1263 -------------------------
1264
1265 procedure Set_Statement_Entry is
1266 SC_Last : constant Int := SC.Last;
1267 SD_Last : constant Int := SD.Last;
1268
1269 begin
1270 -- Output statement entries from saved entries in SC table
1271
1272 for J in SC_First .. SC_Last loop
1273 if J = SC_First then
1274
1275 if Current_Dominant /= No_Dominant then
1276 declare
1277 From, To : Source_Ptr;
1278 begin
1279 Sloc_Range (Current_Dominant.N, From, To);
1280 if Current_Dominant.K /= 'E' then
1281 To := No_Location;
1282 end if;
1283 Set_Table_Entry
1284 (C1 => '>',
1285 C2 => Current_Dominant.K,
1286 From => From,
1287 To => To,
1288 Last => False,
1289 Pragma_Sloc => No_Location,
1290 Pragma_Aspect_Name => No_Name);
1291 end;
1292 end if;
1293 end if;
1294
1295 declare
1296 SCE : SC_Entry renames SC.Table (J);
1297 Pragma_Sloc : Source_Ptr := No_Location;
1298 Pragma_Aspect_Name : Name_Id := No_Name;
1299 begin
1300 -- For the case of a statement SCO for a pragma controlled by
1301 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
1302 -- those of any nested decision) is emitted only if the pragma
1303 -- is enabled.
1304
1305 if SCE.Typ = 'p' then
1306 Pragma_Sloc := SCE.From;
1307 Condition_Pragma_Hash_Table.Set
1308 (Pragma_Sloc, SCO_Table.Last + 1);
1309 Pragma_Aspect_Name := Pragma_Name (SCE.N);
1310 pragma Assert (Pragma_Aspect_Name /= No_Name);
1311
1312 elsif SCE.Typ = 'P' then
1313 Pragma_Aspect_Name := Pragma_Name (SCE.N);
1314 pragma Assert (Pragma_Aspect_Name /= No_Name);
1315 end if;
1316
1317 Set_Table_Entry
1318 (C1 => 'S',
1319 C2 => SCE.Typ,
1320 From => SCE.From,
1321 To => SCE.To,
1322 Last => (J = SC_Last),
1323 Pragma_Sloc => Pragma_Sloc,
1324 Pragma_Aspect_Name => Pragma_Aspect_Name);
1325 end;
1326 end loop;
1327
1328 -- Last statement of basic block, if present, becomes new current
1329 -- dominant.
1330
1331 if SC_Last >= SC_First then
1332 Current_Dominant := ('S', SC.Table (SC_Last).N);
1333 end if;
1334
1335 -- Clear out used section of SC table
1336
1337 SC.Set_Last (SC_First - 1);
1338
1339 -- Output any embedded decisions
1340
1341 for J in SD_First .. SD_Last loop
1342 declare
1343 SDE : SD_Entry renames SD.Table (J);
1344 begin
1345 if Present (SDE.Nod) then
1346 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
1347 else
1348 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
1349 end if;
1350 end;
1351 end loop;
1352
1353 -- Clear out used section of SD table
1354
1355 SD.Set_Last (SD_First - 1);
1356 end Set_Statement_Entry;
1357
1358 -------------------------------
1359 -- Extend_Statement_Sequence --
1360 -------------------------------
1361
1362 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1363 F : Source_Ptr;
1364 T : Source_Ptr;
1365 Dummy : Source_Ptr;
1366 To_Node : Node_Id := Empty;
1367
1368 begin
1369 Sloc_Range (N, F, T);
1370
1371 case Nkind (N) is
1372 when N_Accept_Statement =>
1373 if Present (Parameter_Specifications (N)) then
1374 To_Node := Last (Parameter_Specifications (N));
1375 elsif Present (Entry_Index (N)) then
1376 To_Node := Entry_Index (N);
1377 end if;
1378
1379 when N_Case_Statement =>
1380 To_Node := Expression (N);
1381
1382 when N_If_Statement | N_Elsif_Part =>
1383 To_Node := Condition (N);
1384
1385 when N_Extended_Return_Statement =>
1386 To_Node := Last (Return_Object_Declarations (N));
1387
1388 when N_Loop_Statement =>
1389 To_Node := Iteration_Scheme (N);
1390
1391 when N_Selective_Accept |
1392 N_Timed_Entry_Call |
1393 N_Conditional_Entry_Call |
1394 N_Asynchronous_Select |
1395 N_Single_Protected_Declaration |
1396 N_Single_Task_Declaration =>
1397 T := F;
1398
1399 when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
1400 if Has_Aspects (N) then
1401 To_Node := Last (Aspect_Specifications (N));
1402
1403 elsif Present (Discriminant_Specifications (N)) then
1404 To_Node := Last (Discriminant_Specifications (N));
1405
1406 else
1407 To_Node := Defining_Identifier (N);
1408 end if;
1409
1410 when others =>
1411 null;
1412
1413 end case;
1414
1415 if Present (To_Node) then
1416 Sloc_Range (To_Node, Dummy, T);
1417 end if;
1418
1419 SC.Append ((N, F, T, Typ));
1420 end Extend_Statement_Sequence;
1421
1422 -----------------------------
1423 -- Process_Decisions_Defer --
1424 -----------------------------
1425
1426 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1427 begin
1428 SD.Append ((N, No_List, T, Current_Pragma_Sloc));
1429 end Process_Decisions_Defer;
1430
1431 procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1432 begin
1433 SD.Append ((Empty, L, T, Current_Pragma_Sloc));
1434 end Process_Decisions_Defer;
1435
1436 ----------------------
1437 -- Traverse_Aspects --
1438 ----------------------
1439
1440 procedure Traverse_Aspects (N : Node_Id) is
1441 AN : Node_Id;
1442 AE : Node_Id;
1443 C1 : Character;
1444
1445 begin
1446 AN := First (Aspect_Specifications (N));
1447 while Present (AN) loop
1448 AE := Expression (AN);
1449
1450 -- SCOs are generated before semantic analysis/expansion:
1451 -- PPCs are not split yet.
1452
1453 pragma Assert (not Split_PPC (AN));
1454
1455 C1 := ASCII.NUL;
1456
1457 case Get_Aspect_Id (AN) is
1458
1459 -- Aspects rewritten into pragmas controlled by a Check_Policy:
1460 -- Current_Pragma_Sloc must be set to the sloc of the aspect
1461 -- specification. The corresponding pragma will have the same
1462 -- sloc.
1463
1464 when Aspect_Pre |
1465 Aspect_Precondition |
1466 Aspect_Post |
1467 Aspect_Postcondition |
1468 Aspect_Invariant =>
1469
1470 C1 := 'a';
1471
1472 -- Aspects whose checks are generated in client units,
1473 -- regardless of whether or not the check is activated in the
1474 -- unit which contains the declaration: create decision as
1475 -- unconditionally enabled aspect (but still make a pragma
1476 -- entry since Set_SCO_Pragma_Enabled will be called when
1477 -- analyzing actual checks, possibly in other units).
1478
1479 -- Pre/post can have checks in client units too because of
1480 -- inheritance, so should they be moved here???
1481
1482 when Aspect_Predicate |
1483 Aspect_Static_Predicate |
1484 Aspect_Dynamic_Predicate |
1485 Aspect_Type_Invariant =>
1486
1487 C1 := 'A';
1488
1489 -- Other aspects: just process any decision nested in the
1490 -- aspect expression.
1491
1492 when others =>
1493
1494 if Has_Decision (AE) then
1495 C1 := 'X';
1496 end if;
1497
1498 end case;
1499
1500 if C1 /= ASCII.NUL then
1501 pragma Assert (Current_Pragma_Sloc = No_Location);
1502
1503 if C1 = 'a' or else C1 = 'A' then
1504 Current_Pragma_Sloc := Sloc (AN);
1505 end if;
1506
1507 Process_Decisions_Defer (AE, C1);
1508
1509 Current_Pragma_Sloc := No_Location;
1510 end if;
1511
1512 Next (AN);
1513 end loop;
1514 end Traverse_Aspects;
1515
1516 ------------------
1517 -- Traverse_One --
1518 ------------------
1519
1520 procedure Traverse_One (N : Node_Id) is
1521 begin
1522 -- Initialize or extend current statement sequence. Note that for
1523 -- special cases such as IF and Case statements we will modify
1524 -- the range to exclude internal statements that should not be
1525 -- counted as part of the current statement sequence.
1526
1527 case Nkind (N) is
1528
1529 -- Package declaration
1530
1531 when N_Package_Declaration =>
1532 Set_Statement_Entry;
1533 Traverse_Package_Declaration (N, Current_Dominant);
1534
1535 -- Generic package declaration
1536
1537 when N_Generic_Package_Declaration =>
1538 Set_Statement_Entry;
1539 Traverse_Generic_Package_Declaration (N);
1540
1541 -- Package body
1542
1543 when N_Package_Body =>
1544 Set_Statement_Entry;
1545 Traverse_Package_Body (N);
1546
1547 -- Subprogram declaration or subprogram body stub
1548
1549 when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
1550 Process_Decisions_Defer
1551 (Parameter_Specifications (Specification (N)), 'X');
1552
1553 -- Entry declaration
1554
1555 when N_Entry_Declaration =>
1556 Process_Decisions_Defer (Parameter_Specifications (N), 'X');
1557
1558 -- Generic subprogram declaration
1559
1560 when N_Generic_Subprogram_Declaration =>
1561 Process_Decisions_Defer
1562 (Generic_Formal_Declarations (N), 'X');
1563 Process_Decisions_Defer
1564 (Parameter_Specifications (Specification (N)), 'X');
1565
1566 -- Task or subprogram body
1567
1568 when N_Task_Body | N_Subprogram_Body =>
1569 Set_Statement_Entry;
1570 Traverse_Subprogram_Or_Task_Body (N);
1571
1572 -- Entry body
1573
1574 when N_Entry_Body =>
1575 declare
1576 Cond : constant Node_Id :=
1577 Condition (Entry_Body_Formal_Part (N));
1578
1579 Inner_Dominant : Dominant_Info := No_Dominant;
1580
1581 begin
1582 Set_Statement_Entry;
1583
1584 if Present (Cond) then
1585 Process_Decisions_Defer (Cond, 'G');
1586
1587 -- For an entry body with a barrier, the entry body
1588 -- is dominanted by a True evaluation of the barrier.
1589
1590 Inner_Dominant := ('T', N);
1591 end if;
1592
1593 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
1594 end;
1595
1596 -- Protected body
1597
1598 when N_Protected_Body =>
1599 Set_Statement_Entry;
1600 Traverse_Declarations_Or_Statements (Declarations (N));
1601
1602 -- Exit statement, which is an exit statement in the SCO sense,
1603 -- so it is included in the current statement sequence, but
1604 -- then it terminates this sequence. We also have to process
1605 -- any decisions in the exit statement expression.
1606
1607 when N_Exit_Statement =>
1608 Extend_Statement_Sequence (N, 'E');
1609 Process_Decisions_Defer (Condition (N), 'E');
1610 Set_Statement_Entry;
1611
1612 -- If condition is present, then following statement is
1613 -- only executed if the condition evaluates to False.
1614
1615 if Present (Condition (N)) then
1616 Current_Dominant := ('F', N);
1617 else
1618 Current_Dominant := No_Dominant;
1619 end if;
1620
1621 -- Label, which breaks the current statement sequence, but the
1622 -- label itself is not included in the next statement sequence,
1623 -- since it generates no code.
1624
1625 when N_Label =>
1626 Set_Statement_Entry;
1627 Current_Dominant := No_Dominant;
1628
1629 -- Block statement, which breaks the current statement sequence
1630
1631 when N_Block_Statement =>
1632 Set_Statement_Entry;
1633
1634 -- The first statement in the handled sequence of statements
1635 -- is dominated by the elaboration of the last declaration.
1636
1637 Current_Dominant := Traverse_Declarations_Or_Statements
1638 (L => Declarations (N),
1639 D => Current_Dominant);
1640
1641 Traverse_Handled_Statement_Sequence
1642 (N => Handled_Statement_Sequence (N),
1643 D => Current_Dominant);
1644
1645 -- If statement, which breaks the current statement sequence,
1646 -- but we include the condition in the current sequence.
1647
1648 when N_If_Statement =>
1649 Current_Test := N;
1650 Extend_Statement_Sequence (N, 'I');
1651 Process_Decisions_Defer (Condition (N), 'I');
1652 Set_Statement_Entry;
1653
1654 -- Now we traverse the statements in the THEN part
1655
1656 Traverse_Declarations_Or_Statements
1657 (L => Then_Statements (N),
1658 D => ('T', N));
1659
1660 -- Loop through ELSIF parts if present
1661
1662 if Present (Elsif_Parts (N)) then
1663 declare
1664 Saved_Dominant : constant Dominant_Info :=
1665 Current_Dominant;
1666
1667 Elif : Node_Id := First (Elsif_Parts (N));
1668
1669 begin
1670 while Present (Elif) loop
1671
1672 -- An Elsif is executed only if the previous test
1673 -- got a FALSE outcome.
1674
1675 Current_Dominant := ('F', Current_Test);
1676
1677 -- Now update current test information
1678
1679 Current_Test := Elif;
1680
1681 -- We generate a statement sequence for the
1682 -- construct "ELSIF condition", so that we have
1683 -- a statement for the resulting decisions.
1684
1685 Extend_Statement_Sequence (Elif, 'I');
1686 Process_Decisions_Defer (Condition (Elif), 'I');
1687 Set_Statement_Entry;
1688
1689 -- An ELSIF part is never guaranteed to have
1690 -- been executed, following statements are only
1691 -- dominated by the initial IF statement.
1692
1693 Current_Dominant := Saved_Dominant;
1694
1695 -- Traverse the statements in the ELSIF
1696
1697 Traverse_Declarations_Or_Statements
1698 (L => Then_Statements (Elif),
1699 D => ('T', Elif));
1700 Next (Elif);
1701 end loop;
1702 end;
1703 end if;
1704
1705 -- Finally traverse the ELSE statements if present
1706
1707 Traverse_Declarations_Or_Statements
1708 (L => Else_Statements (N),
1709 D => ('F', Current_Test));
1710
1711 -- CASE statement, which breaks the current statement sequence,
1712 -- but we include the expression in the current sequence.
1713
1714 when N_Case_Statement =>
1715 Extend_Statement_Sequence (N, 'C');
1716 Process_Decisions_Defer (Expression (N), 'X');
1717 Set_Statement_Entry;
1718
1719 -- Process case branches, all of which are dominated by the
1720 -- CASE statement.
1721
1722 declare
1723 Alt : Node_Id;
1724 begin
1725 Alt := First (Alternatives (N));
1726 while Present (Alt) loop
1727 Traverse_Declarations_Or_Statements
1728 (L => Statements (Alt),
1729 D => Current_Dominant);
1730 Next (Alt);
1731 end loop;
1732 end;
1733
1734 -- ACCEPT statement
1735
1736 when N_Accept_Statement =>
1737 Extend_Statement_Sequence (N, 'A');
1738 Set_Statement_Entry;
1739
1740 -- Process sequence of statements, dominant is the ACCEPT
1741 -- statement.
1742
1743 Traverse_Handled_Statement_Sequence
1744 (N => Handled_Statement_Sequence (N),
1745 D => Current_Dominant);
1746
1747 -- SELECT
1748
1749 when N_Selective_Accept =>
1750 Extend_Statement_Sequence (N, 'S');
1751 Set_Statement_Entry;
1752
1753 -- Process alternatives
1754
1755 declare
1756 Alt : Node_Id;
1757 Guard : Node_Id;
1758 S_Dom : Dominant_Info;
1759
1760 begin
1761 Alt := First (Select_Alternatives (N));
1762 while Present (Alt) loop
1763 S_Dom := Current_Dominant;
1764 Guard := Condition (Alt);
1765
1766 if Present (Guard) then
1767 Process_Decisions
1768 (Guard,
1769 'G',
1770 Pragma_Sloc => No_Location);
1771 Current_Dominant := ('T', Guard);
1772 end if;
1773
1774 Traverse_One (Alt);
1775
1776 Current_Dominant := S_Dom;
1777 Next (Alt);
1778 end loop;
1779 end;
1780
1781 Traverse_Declarations_Or_Statements
1782 (L => Else_Statements (N),
1783 D => Current_Dominant);
1784
1785 when N_Timed_Entry_Call | N_Conditional_Entry_Call =>
1786 Extend_Statement_Sequence (N, 'S');
1787 Set_Statement_Entry;
1788
1789 -- Process alternatives
1790
1791 Traverse_One (Entry_Call_Alternative (N));
1792
1793 if Nkind (N) = N_Timed_Entry_Call then
1794 Traverse_One (Delay_Alternative (N));
1795 else
1796 Traverse_Declarations_Or_Statements
1797 (L => Else_Statements (N),
1798 D => Current_Dominant);
1799 end if;
1800
1801 when N_Asynchronous_Select =>
1802 Extend_Statement_Sequence (N, 'S');
1803 Set_Statement_Entry;
1804
1805 Traverse_One (Triggering_Alternative (N));
1806 Traverse_Declarations_Or_Statements
1807 (L => Statements (Abortable_Part (N)),
1808 D => Current_Dominant);
1809
1810 when N_Accept_Alternative =>
1811 Traverse_Declarations_Or_Statements
1812 (L => Statements (N),
1813 D => Current_Dominant,
1814 P => Accept_Statement (N));
1815
1816 when N_Entry_Call_Alternative =>
1817 Traverse_Declarations_Or_Statements
1818 (L => Statements (N),
1819 D => Current_Dominant,
1820 P => Entry_Call_Statement (N));
1821
1822 when N_Delay_Alternative =>
1823 Traverse_Declarations_Or_Statements
1824 (L => Statements (N),
1825 D => Current_Dominant,
1826 P => Delay_Statement (N));
1827
1828 when N_Triggering_Alternative =>
1829 Traverse_Declarations_Or_Statements
1830 (L => Statements (N),
1831 D => Current_Dominant,
1832 P => Triggering_Statement (N));
1833
1834 when N_Terminate_Alternative =>
1835
1836 -- It is dubious to emit a statement SCO for a TERMINATE
1837 -- alternative, since no code is actually executed if the
1838 -- alternative is selected -- the tasking runtime call just
1839 -- never returns???
1840
1841 Extend_Statement_Sequence (N, ' ');
1842 Set_Statement_Entry;
1843
1844 -- Unconditional exit points, which are included in the current
1845 -- statement sequence, but then terminate it
1846
1847 when N_Requeue_Statement |
1848 N_Goto_Statement |
1849 N_Raise_Statement =>
1850 Extend_Statement_Sequence (N, ' ');
1851 Set_Statement_Entry;
1852 Current_Dominant := No_Dominant;
1853
1854 -- Simple return statement. which is an exit point, but we
1855 -- have to process the return expression for decisions.
1856
1857 when N_Simple_Return_Statement =>
1858 Extend_Statement_Sequence (N, ' ');
1859 Process_Decisions_Defer (Expression (N), 'X');
1860 Set_Statement_Entry;
1861 Current_Dominant := No_Dominant;
1862
1863 -- Extended return statement
1864
1865 when N_Extended_Return_Statement =>
1866 Extend_Statement_Sequence (N, 'R');
1867 Process_Decisions_Defer
1868 (Return_Object_Declarations (N), 'X');
1869 Set_Statement_Entry;
1870
1871 Traverse_Handled_Statement_Sequence
1872 (N => Handled_Statement_Sequence (N),
1873 D => Current_Dominant);
1874
1875 Current_Dominant := No_Dominant;
1876
1877 -- Loop ends the current statement sequence, but we include
1878 -- the iteration scheme if present in the current sequence.
1879 -- But the body of the loop starts a new sequence, since it
1880 -- may not be executed as part of the current sequence.
1881
1882 when N_Loop_Statement =>
1883 declare
1884 ISC : constant Node_Id := Iteration_Scheme (N);
1885 Inner_Dominant : Dominant_Info := No_Dominant;
1886
1887 begin
1888 if Present (ISC) then
1889
1890 -- If iteration scheme present, extend the current
1891 -- statement sequence to include the iteration scheme
1892 -- and process any decisions it contains.
1893
1894 -- While loop
1895
1896 if Present (Condition (ISC)) then
1897 Extend_Statement_Sequence (N, 'W');
1898 Process_Decisions_Defer (Condition (ISC), 'W');
1899
1900 -- Set more specific dominant for inner statements
1901 -- (the control sloc for the decision is that of
1902 -- the WHILE token).
1903
1904 Inner_Dominant := ('T', ISC);
1905
1906 -- For loop
1907
1908 else
1909 Extend_Statement_Sequence (N, 'F');
1910 Process_Decisions_Defer
1911 (Loop_Parameter_Specification (ISC), 'X');
1912 end if;
1913 end if;
1914
1915 Set_Statement_Entry;
1916
1917 if Inner_Dominant = No_Dominant then
1918 Inner_Dominant := Current_Dominant;
1919 end if;
1920
1921 Traverse_Declarations_Or_Statements
1922 (L => Statements (N),
1923 D => Inner_Dominant);
1924 end;
1925
1926 -- Pragma
1927
1928 when N_Pragma =>
1929
1930 -- Record sloc of pragma (pragmas don't nest)
1931
1932 pragma Assert (Current_Pragma_Sloc = No_Location);
1933 Current_Pragma_Sloc := Sloc (N);
1934
1935 -- Processing depends on the kind of pragma
1936
1937 declare
1938 Nam : constant Name_Id := Pragma_Name (N);
1939 Arg : Node_Id :=
1940 First (Pragma_Argument_Associations (N));
1941 Typ : Character;
1942
1943 begin
1944 case Nam is
1945 when Name_Assert |
1946 Name_Assert_And_Cut |
1947 Name_Assume |
1948 Name_Check |
1949 Name_Loop_Invariant |
1950 Name_Precondition |
1951 Name_Postcondition =>
1952
1953 -- For Assert/Check/Precondition/Postcondition, we
1954 -- must generate a P entry for the decision. Note
1955 -- that this is done unconditionally at this stage.
1956 -- Output for disabled pragmas is suppressed later
1957 -- on when we output the decision line in Put_SCOs,
1958 -- depending on setting by Set_SCO_Pragma_Enabled.
1959
1960 if Nam = Name_Check then
1961 Next (Arg);
1962 end if;
1963
1964 Process_Decisions_Defer (Expression (Arg), 'P');
1965 Typ := 'p';
1966
1967 -- Pre/postconditions can be inherited so SCO should
1968 -- never be deactivated???
1969
1970 when Name_Debug =>
1971 if Present (Arg) and then Present (Next (Arg)) then
1972
1973 -- Case of a dyadic pragma Debug: first argument
1974 -- is a P decision, any nested decision in the
1975 -- second argument is an X decision.
1976
1977 Process_Decisions_Defer (Expression (Arg), 'P');
1978 Next (Arg);
1979 end if;
1980
1981 Process_Decisions_Defer (Expression (Arg), 'X');
1982 Typ := 'p';
1983
1984 -- For all other pragmas, we generate decision entries
1985 -- for any embedded expressions, and the pragma is
1986 -- never disabled.
1987
1988 -- Should generate P decisions (not X) for assertion
1989 -- related pragmas: [Type_]Invariant,
1990 -- [{Static,Dynamic}_]Predicate???
1991
1992 when others =>
1993 Process_Decisions_Defer (N, 'X');
1994 Typ := 'P';
1995 end case;
1996
1997 -- Add statement SCO
1998
1999 Extend_Statement_Sequence (N, Typ);
2000
2001 Current_Pragma_Sloc := No_Location;
2002 end;
2003
2004 -- Object declaration. Ignored if Prev_Ids is set, since the
2005 -- parser generates multiple instances of the whole declaration
2006 -- if there is more than one identifier declared, and we only
2007 -- want one entry in the SCOs, so we take the first, for which
2008 -- Prev_Ids is False.
2009
2010 when N_Object_Declaration | N_Number_Declaration =>
2011 if not Prev_Ids (N) then
2012 Extend_Statement_Sequence (N, 'o');
2013
2014 if Has_Decision (N) then
2015 Process_Decisions_Defer (N, 'X');
2016 end if;
2017 end if;
2018
2019 -- All other cases, which extend the current statement sequence
2020 -- but do not terminate it, even if they have nested decisions.
2021
2022 when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
2023 Extend_Statement_Sequence (N, 't');
2024 Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
2025 Set_Statement_Entry;
2026
2027 Traverse_Sync_Definition (N);
2028
2029 when N_Single_Protected_Declaration | N_Single_Task_Declaration =>
2030 Extend_Statement_Sequence (N, 'o');
2031 Set_Statement_Entry;
2032
2033 Traverse_Sync_Definition (N);
2034
2035 when others =>
2036
2037 -- Determine required type character code, or ASCII.NUL if
2038 -- no SCO should be generated for this node.
2039
2040 declare
2041 NK : constant Node_Kind := Nkind (N);
2042 Typ : Character;
2043
2044 begin
2045 case NK is
2046 when N_Full_Type_Declaration |
2047 N_Incomplete_Type_Declaration |
2048 N_Private_Type_Declaration |
2049 N_Private_Extension_Declaration =>
2050 Typ := 't';
2051
2052 when N_Subtype_Declaration =>
2053 Typ := 's';
2054
2055 when N_Renaming_Declaration =>
2056 Typ := 'r';
2057
2058 when N_Generic_Instantiation =>
2059 Typ := 'i';
2060
2061 when N_Representation_Clause |
2062 N_Use_Package_Clause |
2063 N_Use_Type_Clause |
2064 N_Package_Body_Stub |
2065 N_Task_Body_Stub |
2066 N_Protected_Body_Stub =>
2067 Typ := ASCII.NUL;
2068
2069 when N_Procedure_Call_Statement =>
2070 Typ := ' ';
2071
2072 when others =>
2073 if NK in N_Statement_Other_Than_Procedure_Call then
2074 Typ := ' ';
2075 else
2076 Typ := 'd';
2077 end if;
2078 end case;
2079
2080 if Typ /= ASCII.NUL then
2081 Extend_Statement_Sequence (N, Typ);
2082 end if;
2083 end;
2084
2085 -- Process any embedded decisions
2086
2087 if Has_Decision (N) then
2088 Process_Decisions_Defer (N, 'X');
2089 end if;
2090 end case;
2091
2092 -- Process aspects if present
2093
2094 Traverse_Aspects (N);
2095 end Traverse_One;
2096
2097 -- Start of processing for Traverse_Declarations_Or_Statements
2098
2099 begin
2100 -- Process single prefixed node
2101
2102 if Present (P) then
2103 Traverse_One (P);
2104 end if;
2105
2106 -- Loop through statements or declarations
2107
2108 if Is_Non_Empty_List (L) then
2109 N := First (L);
2110 while Present (N) loop
2111
2112 -- Note: For separate bodies, we see the tree after Par.Labl has
2113 -- introduced implicit labels, so we need to ignore those nodes.
2114
2115 if Nkind (N) /= N_Implicit_Label_Declaration then
2116 Traverse_One (N);
2117 end if;
2118
2119 Next (N);
2120 end loop;
2121
2122 end if;
2123
2124 -- End sequence of statements and flush deferred decisions
2125
2126 if Present (P) or else Is_Non_Empty_List (L) then
2127 Set_Statement_Entry;
2128 end if;
2129
2130 return Current_Dominant;
2131 end Traverse_Declarations_Or_Statements;
2132
2133 ------------------------------------------
2134 -- Traverse_Generic_Package_Declaration --
2135 ------------------------------------------
2136
2137 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
2138 begin
2139 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
2140 Traverse_Package_Declaration (N);
2141 end Traverse_Generic_Package_Declaration;
2142
2143 -----------------------------------------
2144 -- Traverse_Handled_Statement_Sequence --
2145 -----------------------------------------
2146
2147 procedure Traverse_Handled_Statement_Sequence
2148 (N : Node_Id;
2149 D : Dominant_Info := No_Dominant)
2150 is
2151 Handler : Node_Id;
2152
2153 begin
2154 -- For package bodies without a statement part, the parser adds an empty
2155 -- one, to normalize the representation. The null statement therein,
2156 -- which does not come from source, does not get a SCO.
2157
2158 if Present (N) and then Comes_From_Source (N) then
2159 Traverse_Declarations_Or_Statements (Statements (N), D);
2160
2161 if Present (Exception_Handlers (N)) then
2162 Handler := First (Exception_Handlers (N));
2163 while Present (Handler) loop
2164 Traverse_Declarations_Or_Statements
2165 (L => Statements (Handler),
2166 D => ('E', Handler));
2167 Next (Handler);
2168 end loop;
2169 end if;
2170 end if;
2171 end Traverse_Handled_Statement_Sequence;
2172
2173 ---------------------------
2174 -- Traverse_Package_Body --
2175 ---------------------------
2176
2177 procedure Traverse_Package_Body (N : Node_Id) is
2178 Dom : Dominant_Info;
2179 begin
2180 -- The first statement in the handled sequence of statements is
2181 -- dominated by the elaboration of the last declaration.
2182
2183 Dom := Traverse_Declarations_Or_Statements (Declarations (N));
2184
2185 Traverse_Handled_Statement_Sequence
2186 (Handled_Statement_Sequence (N), Dom);
2187 end Traverse_Package_Body;
2188
2189 ----------------------------------
2190 -- Traverse_Package_Declaration --
2191 ----------------------------------
2192
2193 procedure Traverse_Package_Declaration
2194 (N : Node_Id;
2195 D : Dominant_Info := No_Dominant)
2196 is
2197 Spec : constant Node_Id := Specification (N);
2198 Dom : Dominant_Info;
2199
2200 begin
2201 Dom :=
2202 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D);
2203
2204 -- First private declaration is dominated by last visible declaration
2205
2206 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
2207 end Traverse_Package_Declaration;
2208
2209 ------------------------------
2210 -- Traverse_Sync_Definition --
2211 ------------------------------
2212
2213 procedure Traverse_Sync_Definition (N : Node_Id) is
2214 Dom_Info : Dominant_Info := ('S', N);
2215 -- The first declaration is dominated by the protected or task [type]
2216 -- declaration.
2217
2218 Sync_Def : Node_Id;
2219 -- N's protected or task definition
2220
2221 Vis_Decl : List_Id;
2222 -- Sync_Def's Visible_Declarations
2223
2224 begin
2225 case Nkind (N) is
2226 when N_Single_Protected_Declaration | N_Protected_Type_Declaration =>
2227 Sync_Def := Protected_Definition (N);
2228
2229 when N_Single_Task_Declaration | N_Task_Type_Declaration =>
2230 Sync_Def := Task_Definition (N);
2231
2232 when others =>
2233 raise Program_Error;
2234 end case;
2235
2236 Vis_Decl := Visible_Declarations (Sync_Def);
2237
2238 Dom_Info := Traverse_Declarations_Or_Statements
2239 (L => Vis_Decl,
2240 D => Dom_Info);
2241
2242 -- If visible declarations are present, the first private declaration
2243 -- is dominated by the last visible declaration.
2244
2245 Traverse_Declarations_Or_Statements
2246 (L => Private_Declarations (Sync_Def),
2247 D => Dom_Info);
2248 end Traverse_Sync_Definition;
2249
2250 --------------------------------------
2251 -- Traverse_Subprogram_Or_Task_Body --
2252 --------------------------------------
2253
2254 procedure Traverse_Subprogram_Or_Task_Body
2255 (N : Node_Id;
2256 D : Dominant_Info := No_Dominant)
2257 is
2258 Decls : constant List_Id := Declarations (N);
2259 Dom_Info : Dominant_Info := D;
2260 begin
2261 -- If declarations are present, the first statement is dominated by the
2262 -- last declaration.
2263
2264 Dom_Info := Traverse_Declarations_Or_Statements
2265 (L => Decls, D => Dom_Info);
2266
2267 Traverse_Handled_Statement_Sequence
2268 (N => Handled_Statement_Sequence (N),
2269 D => Dom_Info);
2270 end Traverse_Subprogram_Or_Task_Body;
2271
2272 end Par_SCO;
Mirror of the offical gcc git repository hosted at gcc.gnu.org