?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / par_sco.adb
blobce54f117e34ba4c60a0b4a500a508a875df311af
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
1548
1549 when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
1550 Process_Decisions_Defer
1551 (Parameter_Specifications (Specification (N)), 'X');
1552
1553 -- Generic subprogram declaration
1554
1555 when N_Generic_Subprogram_Declaration =>
1556 Process_Decisions_Defer
1557 (Generic_Formal_Declarations (N), 'X');
1558 Process_Decisions_Defer
1559 (Parameter_Specifications (Specification (N)), 'X');
1560
1561 -- Task or subprogram body
1562
1563 when N_Task_Body | N_Subprogram_Body =>
1564 Set_Statement_Entry;
1565 Traverse_Subprogram_Or_Task_Body (N);
1566
1567 -- Entry body
1568
1569 when N_Entry_Body =>
1570 declare
1571 Cond : constant Node_Id :=
1572 Condition (Entry_Body_Formal_Part (N));
1573
1574 Inner_Dominant : Dominant_Info := No_Dominant;
1575
1576 begin
1577 Set_Statement_Entry;
1578
1579 if Present (Cond) then
1580 Process_Decisions_Defer (Cond, 'G');
1581
1582 -- For an entry body with a barrier, the entry body
1583 -- is dominanted by a True evaluation of the barrier.
1584
1585 Inner_Dominant := ('T', N);
1586 end if;
1587
1588 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
1589 end;
1590
1591 -- Protected body
1592
1593 when N_Protected_Body =>
1594 Set_Statement_Entry;
1595 Traverse_Declarations_Or_Statements (Declarations (N));
1596
1597 -- Exit statement, which is an exit statement in the SCO sense,
1598 -- so it is included in the current statement sequence, but
1599 -- then it terminates this sequence. We also have to process
1600 -- any decisions in the exit statement expression.
1601
1602 when N_Exit_Statement =>
1603 Extend_Statement_Sequence (N, ' ');
1604 Process_Decisions_Defer (Condition (N), 'E');
1605 Set_Statement_Entry;
1606
1607 -- If condition is present, then following statement is
1608 -- only executed if the condition evaluates to False.
1609
1610 if Present (Condition (N)) then
1611 Current_Dominant := ('F', N);
1612 else
1613 Current_Dominant := No_Dominant;
1614 end if;
1615
1616 -- Label, which breaks the current statement sequence, but the
1617 -- label itself is not included in the next statement sequence,
1618 -- since it generates no code.
1619
1620 when N_Label =>
1621 Set_Statement_Entry;
1622 Current_Dominant := No_Dominant;
1623
1624 -- Block statement, which breaks the current statement sequence
1625
1626 when N_Block_Statement =>
1627 Set_Statement_Entry;
1628
1629 -- The first statement in the handled sequence of statements
1630 -- is dominated by the elaboration of the last declaration.
1631
1632 Current_Dominant := Traverse_Declarations_Or_Statements
1633 (L => Declarations (N),
1634 D => Current_Dominant);
1635
1636 Traverse_Handled_Statement_Sequence
1637 (N => Handled_Statement_Sequence (N),
1638 D => Current_Dominant);
1639
1640 -- If statement, which breaks the current statement sequence,
1641 -- but we include the condition in the current sequence.
1642
1643 when N_If_Statement =>
1644 Current_Test := N;
1645 Extend_Statement_Sequence (N, 'I');
1646 Process_Decisions_Defer (Condition (N), 'I');
1647 Set_Statement_Entry;
1648
1649 -- Now we traverse the statements in the THEN part
1650
1651 Traverse_Declarations_Or_Statements
1652 (L => Then_Statements (N),
1653 D => ('T', N));
1654
1655 -- Loop through ELSIF parts if present
1656
1657 if Present (Elsif_Parts (N)) then
1658 declare
1659 Saved_Dominant : constant Dominant_Info :=
1660 Current_Dominant;
1661
1662 Elif : Node_Id := First (Elsif_Parts (N));
1663
1664 begin
1665 while Present (Elif) loop
1666
1667 -- An Elsif is executed only if the previous test
1668 -- got a FALSE outcome.
1669
1670 Current_Dominant := ('F', Current_Test);
1671
1672 -- Now update current test information
1673
1674 Current_Test := Elif;
1675
1676 -- We generate a statement sequence for the
1677 -- construct "ELSIF condition", so that we have
1678 -- a statement for the resulting decisions.
1679
1680 Extend_Statement_Sequence (Elif, 'I');
1681 Process_Decisions_Defer (Condition (Elif), 'I');
1682 Set_Statement_Entry;
1683
1684 -- An ELSIF part is never guaranteed to have
1685 -- been executed, following statements are only
1686 -- dominated by the initial IF statement.
1687
1688 Current_Dominant := Saved_Dominant;
1689
1690 -- Traverse the statements in the ELSIF
1691
1692 Traverse_Declarations_Or_Statements
1693 (L => Then_Statements (Elif),
1694 D => ('T', Elif));
1695 Next (Elif);
1696 end loop;
1697 end;
1698 end if;
1699
1700 -- Finally traverse the ELSE statements if present
1701
1702 Traverse_Declarations_Or_Statements
1703 (L => Else_Statements (N),
1704 D => ('F', Current_Test));
1705
1706 -- CASE statement, which breaks the current statement sequence,
1707 -- but we include the expression in the current sequence.
1708
1709 when N_Case_Statement =>
1710 Extend_Statement_Sequence (N, 'C');
1711 Process_Decisions_Defer (Expression (N), 'X');
1712 Set_Statement_Entry;
1713
1714 -- Process case branches, all of which are dominated by the
1715 -- CASE statement.
1716
1717 declare
1718 Alt : Node_Id;
1719 begin
1720 Alt := First (Alternatives (N));
1721 while Present (Alt) loop
1722 Traverse_Declarations_Or_Statements
1723 (L => Statements (Alt),
1724 D => Current_Dominant);
1725 Next (Alt);
1726 end loop;
1727 end;
1728
1729 -- ACCEPT statement
1730
1731 when N_Accept_Statement =>
1732 Extend_Statement_Sequence (N, 'A');
1733 Set_Statement_Entry;
1734
1735 -- Process sequence of statements, dominant is the ACCEPT
1736 -- statement.
1737
1738 Traverse_Handled_Statement_Sequence
1739 (N => Handled_Statement_Sequence (N),
1740 D => Current_Dominant);
1741
1742 -- SELECT
1743
1744 when N_Selective_Accept =>
1745 Extend_Statement_Sequence (N, 'S');
1746 Set_Statement_Entry;
1747
1748 -- Process alternatives
1749
1750 declare
1751 Alt : Node_Id;
1752 Guard : Node_Id;
1753 S_Dom : Dominant_Info;
1754
1755 begin
1756 Alt := First (Select_Alternatives (N));
1757 while Present (Alt) loop
1758 S_Dom := Current_Dominant;
1759 Guard := Condition (Alt);
1760
1761 if Present (Guard) then
1762 Process_Decisions
1763 (Guard,
1764 'G',
1765 Pragma_Sloc => No_Location);
1766 Current_Dominant := ('T', Guard);
1767 end if;
1768
1769 Traverse_One (Alt);
1770
1771 Current_Dominant := S_Dom;
1772 Next (Alt);
1773 end loop;
1774 end;
1775
1776 Traverse_Declarations_Or_Statements
1777 (L => Else_Statements (N),
1778 D => Current_Dominant);
1779
1780 when N_Timed_Entry_Call | N_Conditional_Entry_Call =>
1781 Extend_Statement_Sequence (N, 'S');
1782 Set_Statement_Entry;
1783
1784 -- Process alternatives
1785
1786 Traverse_One (Entry_Call_Alternative (N));
1787
1788 if Nkind (N) = N_Timed_Entry_Call then
1789 Traverse_One (Delay_Alternative (N));
1790 else
1791 Traverse_Declarations_Or_Statements
1792 (L => Else_Statements (N),
1793 D => Current_Dominant);
1794 end if;
1795
1796 when N_Asynchronous_Select =>
1797 Extend_Statement_Sequence (N, 'S');
1798 Set_Statement_Entry;
1799
1800 Traverse_One (Triggering_Alternative (N));
1801 Traverse_Declarations_Or_Statements
1802 (L => Statements (Abortable_Part (N)),
1803 D => Current_Dominant);
1804
1805 when N_Accept_Alternative =>
1806 Traverse_Declarations_Or_Statements
1807 (L => Statements (N),
1808 D => Current_Dominant,
1809 P => Accept_Statement (N));
1810
1811 when N_Entry_Call_Alternative =>
1812 Traverse_Declarations_Or_Statements
1813 (L => Statements (N),
1814 D => Current_Dominant,
1815 P => Entry_Call_Statement (N));
1816
1817 when N_Delay_Alternative =>
1818 Traverse_Declarations_Or_Statements
1819 (L => Statements (N),
1820 D => Current_Dominant,
1821 P => Delay_Statement (N));
1822
1823 when N_Triggering_Alternative =>
1824 Traverse_Declarations_Or_Statements
1825 (L => Statements (N),
1826 D => Current_Dominant,
1827 P => Triggering_Statement (N));
1828
1829 when N_Terminate_Alternative =>
1830
1831 -- It is dubious to emit a statement SCO for a TERMINATE
1832 -- alternative, since no code is actually executed if the
1833 -- alternative is selected -- the tasking runtime call just
1834 -- never returns???
1835
1836 Extend_Statement_Sequence (N, ' ');
1837 Set_Statement_Entry;
1838
1839 -- Unconditional exit points, which are included in the current
1840 -- statement sequence, but then terminate it
1841
1842 when N_Requeue_Statement |
1843 N_Goto_Statement |
1844 N_Raise_Statement =>
1845 Extend_Statement_Sequence (N, ' ');
1846 Set_Statement_Entry;
1847 Current_Dominant := No_Dominant;
1848
1849 -- Simple return statement. which is an exit point, but we
1850 -- have to process the return expression for decisions.
1851
1852 when N_Simple_Return_Statement =>
1853 Extend_Statement_Sequence (N, ' ');
1854 Process_Decisions_Defer (Expression (N), 'X');
1855 Set_Statement_Entry;
1856 Current_Dominant := No_Dominant;
1857
1858 -- Extended return statement
1859
1860 when N_Extended_Return_Statement =>
1861 Extend_Statement_Sequence (N, 'R');
1862 Process_Decisions_Defer
1863 (Return_Object_Declarations (N), 'X');
1864 Set_Statement_Entry;
1865
1866 Traverse_Handled_Statement_Sequence
1867 (N => Handled_Statement_Sequence (N),
1868 D => Current_Dominant);
1869
1870 Current_Dominant := No_Dominant;
1871
1872 -- Loop ends the current statement sequence, but we include
1873 -- the iteration scheme if present in the current sequence.
1874 -- But the body of the loop starts a new sequence, since it
1875 -- may not be executed as part of the current sequence.
1876
1877 when N_Loop_Statement =>
1878 declare
1879 ISC : constant Node_Id := Iteration_Scheme (N);
1880 Inner_Dominant : Dominant_Info := No_Dominant;
1881
1882 begin
1883 if Present (ISC) then
1884
1885 -- If iteration scheme present, extend the current
1886 -- statement sequence to include the iteration scheme
1887 -- and process any decisions it contains.
1888
1889 -- While loop
1890
1891 if Present (Condition (ISC)) then
1892 Extend_Statement_Sequence (N, 'W');
1893 Process_Decisions_Defer (Condition (ISC), 'W');
1894
1895 -- Set more specific dominant for inner statements
1896 -- (the control sloc for the decision is that of
1897 -- the WHILE token).
1898
1899 Inner_Dominant := ('T', ISC);
1900
1901 -- For loop
1902
1903 else
1904 Extend_Statement_Sequence (N, 'F');
1905 Process_Decisions_Defer
1906 (Loop_Parameter_Specification (ISC), 'X');
1907 end if;
1908 end if;
1909
1910 Set_Statement_Entry;
1911
1912 if Inner_Dominant = No_Dominant then
1913 Inner_Dominant := Current_Dominant;
1914 end if;
1915
1916 Traverse_Declarations_Or_Statements
1917 (L => Statements (N),
1918 D => Inner_Dominant);
1919 end;
1920
1921 -- Pragma
1922
1923 when N_Pragma =>
1924
1925 -- Record sloc of pragma (pragmas don't nest)
1926
1927 pragma Assert (Current_Pragma_Sloc = No_Location);
1928 Current_Pragma_Sloc := Sloc (N);
1929
1930 -- Processing depends on the kind of pragma
1931
1932 declare
1933 Nam : constant Name_Id := Pragma_Name (N);
1934 Arg : Node_Id :=
1935 First (Pragma_Argument_Associations (N));
1936 Typ : Character;
1937
1938 begin
1939 case Nam is
1940 when Name_Assert |
1941 Name_Assert_And_Cut |
1942 Name_Assume |
1943 Name_Check |
1944 Name_Loop_Invariant |
1945 Name_Precondition |
1946 Name_Postcondition =>
1947
1948 -- For Assert/Check/Precondition/Postcondition, we
1949 -- must generate a P entry for the decision. Note
1950 -- that this is done unconditionally at this stage.
1951 -- Output for disabled pragmas is suppressed later
1952 -- on when we output the decision line in Put_SCOs,
1953 -- depending on setting by Set_SCO_Pragma_Enabled.
1954
1955 if Nam = Name_Check then
1956 Next (Arg);
1957 end if;
1958
1959 Process_Decisions_Defer (Expression (Arg), 'P');
1960 Typ := 'p';
1961
1962 -- Pre/postconditions can be inherited so SCO should
1963 -- never be deactivated???
1964
1965 when Name_Debug =>
1966 if Present (Arg) and then Present (Next (Arg)) then
1967
1968 -- Case of a dyadic pragma Debug: first argument
1969 -- is a P decision, any nested decision in the
1970 -- second argument is an X decision.
1971
1972 Process_Decisions_Defer (Expression (Arg), 'P');
1973 Next (Arg);
1974 end if;
1975
1976 Process_Decisions_Defer (Expression (Arg), 'X');
1977 Typ := 'p';
1978
1979 -- For all other pragmas, we generate decision entries
1980 -- for any embedded expressions, and the pragma is
1981 -- never disabled.
1982
1983 -- Should generate P decisions (not X) for assertion
1984 -- related pragmas: [Type_]Invariant,
1985 -- [{Static,Dynamic}_]Predicate???
1986
1987 when others =>
1988 Process_Decisions_Defer (N, 'X');
1989 Typ := 'P';
1990 end case;
1991
1992 -- Add statement SCO
1993
1994 Extend_Statement_Sequence (N, Typ);
1995
1996 Current_Pragma_Sloc := No_Location;
1997 end;
1998
1999 -- Object declaration. Ignored if Prev_Ids is set, since the
2000 -- parser generates multiple instances of the whole declaration
2001 -- if there is more than one identifier declared, and we only
2002 -- want one entry in the SCOs, so we take the first, for which
2003 -- Prev_Ids is False.
2004
2005 when N_Object_Declaration =>
2006 if not Prev_Ids (N) then
2007 Extend_Statement_Sequence (N, 'o');
2008
2009 if Has_Decision (N) then
2010 Process_Decisions_Defer (N, 'X');
2011 end if;
2012 end if;
2013
2014 -- All other cases, which extend the current statement sequence
2015 -- but do not terminate it, even if they have nested decisions.
2016
2017 when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
2018 Extend_Statement_Sequence (N, 't');
2019 Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
2020 Set_Statement_Entry;
2021
2022 Traverse_Sync_Definition (N);
2023
2024 when N_Single_Protected_Declaration | N_Single_Task_Declaration =>
2025 Extend_Statement_Sequence (N, 'o');
2026 Set_Statement_Entry;
2027
2028 Traverse_Sync_Definition (N);
2029
2030 when others =>
2031
2032 -- Determine required type character code, or ASCII.NUL if
2033 -- no SCO should be generated for this node.
2034
2035 declare
2036 Typ : Character;
2037
2038 begin
2039 case Nkind (N) is
2040 when N_Full_Type_Declaration |
2041 N_Incomplete_Type_Declaration |
2042 N_Private_Type_Declaration |
2043 N_Private_Extension_Declaration =>
2044 Typ := 't';
2045
2046 when N_Subtype_Declaration =>
2047 Typ := 's';
2048
2049 when N_Renaming_Declaration =>
2050 Typ := 'r';
2051
2052 when N_Generic_Instantiation =>
2053 Typ := 'i';
2054
2055 when N_Representation_Clause |
2056 N_Use_Package_Clause |
2057 N_Use_Type_Clause |
2058 N_Package_Body_Stub |
2059 N_Task_Body_Stub |
2060 N_Protected_Body_Stub =>
2061 Typ := ASCII.NUL;
2062
2063 when others =>
2064 Typ := ' ';
2065 end case;
2066
2067 if Typ /= ASCII.NUL then
2068 Extend_Statement_Sequence (N, Typ);
2069 end if;
2070 end;
2071
2072 -- Process any embedded decisions
2073
2074 if Has_Decision (N) then
2075 Process_Decisions_Defer (N, 'X');
2076 end if;
2077 end case;
2078
2079 -- Process aspects if present
2080
2081 Traverse_Aspects (N);
2082 end Traverse_One;
2083
2084 -- Start of processing for Traverse_Declarations_Or_Statements
2085
2086 begin
2087 -- Process single prefixed node
2088
2089 if Present (P) then
2090 Traverse_One (P);
2091 end if;
2092
2093 -- Loop through statements or declarations
2094
2095 if Is_Non_Empty_List (L) then
2096 N := First (L);
2097 while Present (N) loop
2098
2099 -- Note: For separate bodies, we see the tree after Par.Labl has
2100 -- introduced implicit labels, so we need to ignore those nodes.
2101
2102 if Nkind (N) /= N_Implicit_Label_Declaration then
2103 Traverse_One (N);
2104 end if;
2105
2106 Next (N);
2107 end loop;
2108
2109 end if;
2110
2111 -- End sequence of statements and flush deferred decisions
2112
2113 if Present (P) or else Is_Non_Empty_List (L) then
2114 Set_Statement_Entry;
2115 end if;
2116
2117 return Current_Dominant;
2118 end Traverse_Declarations_Or_Statements;
2119
2120 ------------------------------------------
2121 -- Traverse_Generic_Package_Declaration --
2122 ------------------------------------------
2123
2124 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
2125 begin
2126 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
2127 Traverse_Package_Declaration (N);
2128 end Traverse_Generic_Package_Declaration;
2129
2130 -----------------------------------------
2131 -- Traverse_Handled_Statement_Sequence --
2132 -----------------------------------------
2133
2134 procedure Traverse_Handled_Statement_Sequence
2135 (N : Node_Id;
2136 D : Dominant_Info := No_Dominant)
2137 is
2138 Handler : Node_Id;
2139
2140 begin
2141 -- For package bodies without a statement part, the parser adds an empty
2142 -- one, to normalize the representation. The null statement therein,
2143 -- which does not come from source, does not get a SCO.
2144
2145 if Present (N) and then Comes_From_Source (N) then
2146 Traverse_Declarations_Or_Statements (Statements (N), D);
2147
2148 if Present (Exception_Handlers (N)) then
2149 Handler := First (Exception_Handlers (N));
2150 while Present (Handler) loop
2151 Traverse_Declarations_Or_Statements
2152 (L => Statements (Handler),
2153 D => ('E', Handler));
2154 Next (Handler);
2155 end loop;
2156 end if;
2157 end if;
2158 end Traverse_Handled_Statement_Sequence;
2159
2160 ---------------------------
2161 -- Traverse_Package_Body --
2162 ---------------------------
2163
2164 procedure Traverse_Package_Body (N : Node_Id) is
2165 Dom : Dominant_Info;
2166 begin
2167 -- The first statement in the handled sequence of statements is
2168 -- dominated by the elaboration of the last declaration.
2169
2170 Dom := Traverse_Declarations_Or_Statements (Declarations (N));
2171
2172 Traverse_Handled_Statement_Sequence
2173 (Handled_Statement_Sequence (N), Dom);
2174 end Traverse_Package_Body;
2175
2176 ----------------------------------
2177 -- Traverse_Package_Declaration --
2178 ----------------------------------
2179
2180 procedure Traverse_Package_Declaration
2181 (N : Node_Id;
2182 D : Dominant_Info := No_Dominant)
2183 is
2184 Spec : constant Node_Id := Specification (N);
2185 Dom : Dominant_Info;
2186
2187 begin
2188 Dom :=
2189 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D);
2190
2191 -- First private declaration is dominated by last visible declaration
2192
2193 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
2194 end Traverse_Package_Declaration;
2195
2196 ------------------------------
2197 -- Traverse_Sync_Definition --
2198 ------------------------------
2199
2200 procedure Traverse_Sync_Definition (N : Node_Id) is
2201 Dom_Info : Dominant_Info := ('S', N);
2202 -- The first declaration is dominated by the protected or task [type]
2203 -- declaration.
2204
2205 Sync_Def : Node_Id;
2206 -- N's protected or task definition
2207
2208 Vis_Decl : List_Id;
2209 -- Sync_Def's Visible_Declarations
2210
2211 begin
2212 case Nkind (N) is
2213 when N_Single_Protected_Declaration | N_Protected_Type_Declaration =>
2214 Sync_Def := Protected_Definition (N);
2215
2216 when N_Single_Task_Declaration | N_Task_Type_Declaration =>
2217 Sync_Def := Task_Definition (N);
2218
2219 when others =>
2220 raise Program_Error;
2221 end case;
2222
2223 Vis_Decl := Visible_Declarations (Sync_Def);
2224
2225 Dom_Info := Traverse_Declarations_Or_Statements
2226 (L => Vis_Decl,
2227 D => Dom_Info);
2228
2229 -- If visible declarations are present, the first private declaration
2230 -- is dominated by the last visible declaration.
2231
2232 Traverse_Declarations_Or_Statements
2233 (L => Private_Declarations (Sync_Def),
2234 D => Dom_Info);
2235 end Traverse_Sync_Definition;
2236
2237 --------------------------------------
2238 -- Traverse_Subprogram_Or_Task_Body --
2239 --------------------------------------
2240
2241 procedure Traverse_Subprogram_Or_Task_Body
2242 (N : Node_Id;
2243 D : Dominant_Info := No_Dominant)
2244 is
2245 Decls : constant List_Id := Declarations (N);
2246 Dom_Info : Dominant_Info := D;
2247 begin
2248 -- If declarations are present, the first statement is dominated by the
2249 -- last declaration.
2250
2251 Dom_Info := Traverse_Declarations_Or_Statements
2252 (L => Decls, D => Dom_Info);
2253
2254 Traverse_Handled_Statement_Sequence
2255 (N => Handled_Statement_Sequence (N),
2256 D => Dom_Info);
2257 end Traverse_Subprogram_Or_Task_Body;
2258
2259 end Par_SCO;
Mirror of the offical gcc git repository hosted at gcc.gnu.org