projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
[multiple changes]
[gcc.git] / gcc / ada / par_sco.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P A R _ S C O --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2009-2011, 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 Atree; use Atree;
27 with Debug; use Debug;
28 with Lib; use Lib;
29 with Lib.Util; use Lib.Util;
30 with Namet; use Namet;
31 with Nlists; use Nlists;
32 with Opt; use Opt;
33 with Output; use Output;
34 with Put_SCOs;
35 with SCOs; use SCOs;
36 with Sinfo; use Sinfo;
37 with Sinput; use Sinput;
38 with Snames; use Snames;
39 with Table;
40
41 with GNAT.HTable; use GNAT.HTable;
42 with GNAT.Heap_Sort_G;
43
44 package body Par_SCO is
45
46 -----------------------
47 -- Unit Number Table --
48 -----------------------
49
50 -- This table parallels the SCO_Unit_Table, keeping track of the unit
51 -- numbers corresponding to the entries made in this table, so that before
52 -- writing out the SCO information to the ALI file, we can fill in the
53 -- proper dependency numbers and file names.
54
55 -- Note that the zero'th entry is here for convenience in sorting the
56 -- table, the real lower bound is 1.
57
58 package SCO_Unit_Number_Table is new Table.Table (
59 Table_Component_Type => Unit_Number_Type,
60 Table_Index_Type => SCO_Unit_Index,
61 Table_Low_Bound => 0, -- see note above on sort
62 Table_Initial => 20,
63 Table_Increment => 200,
64 Table_Name => "SCO_Unit_Number_Entry");
65
66 ---------------------------------
67 -- Condition/Pragma Hash Table --
68 ---------------------------------
69
70 -- We need to be able to get to conditions quickly for handling the calls
71 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
72 -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify
73 -- the conditions and pragmas in the table by their starting sloc, and use
74 -- this hash table to map from these sloc values to SCO_Table indexes.
75
76 type Header_Num is new Integer range 0 .. 996;
77 -- Type for hash table headers
78
79 function Hash (F : Source_Ptr) return Header_Num;
80 -- Function to Hash source pointer value
81
82 function Equal (F1, F2 : Source_Ptr) return Boolean;
83 -- Function to test two keys for equality
84
85 package Condition_Pragma_Hash_Table is new Simple_HTable
86 (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
87 -- The actual hash table
88
89 --------------------------
90 -- Internal Subprograms --
91 --------------------------
92
93 function Has_Decision (N : Node_Id) return Boolean;
94 -- N is the node for a subexpression. Returns True if the subexpression
95 -- contains a nested decision (i.e. either is a logical operator, or
96 -- contains a logical operator in its subtree).
97
98 function Is_Logical_Operator (N : Node_Id) return Boolean;
99 -- N is the node for a subexpression. This procedure just tests N to see
100 -- if it is a logical operator (including short circuit conditions, but
101 -- excluding OR and AND) and returns True if so, False otherwise, it does
102 -- no other processing.
103
104 procedure Process_Decisions
105 (N : Node_Id;
106 T : Character;
107 Pragma_Sloc : Source_Ptr);
108 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
109 -- to output any decisions it contains. T is one of IEGPWX (for context of
110 -- expression: if/exit when/entry guard/pragma/while/expression). If T is
111 -- other than X, the node N is the conditional expression involved, and a
112 -- decision is always present (at the very least a simple decision is
113 -- present at the top level).
114
115 procedure Process_Decisions
116 (L : List_Id;
117 T : Character;
118 Pragma_Sloc : Source_Ptr);
119 -- Calls above procedure for each element of the list L
120
121 procedure Set_Table_Entry
122 (C1 : Character;
123 C2 : Character;
124 From : Source_Ptr;
125 To : Source_Ptr;
126 Last : Boolean;
127 Pragma_Sloc : Source_Ptr := No_Location);
128 -- Append an entry to SCO_Table with fields set as per arguments
129
130 procedure Traverse_Declarations_Or_Statements (L : List_Id);
131 procedure Traverse_Generic_Instantiation (N : Node_Id);
132 procedure Traverse_Generic_Package_Declaration (N : Node_Id);
133 procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
134 procedure Traverse_Package_Body (N : Node_Id);
135 procedure Traverse_Package_Declaration (N : Node_Id);
136 procedure Traverse_Protected_Body (N : Node_Id);
137 procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id);
138 procedure Traverse_Subprogram_Declaration (N : Node_Id);
139 -- Traverse the corresponding construct, generating SCO table entries
140
141 procedure Write_SCOs_To_ALI_File is new Put_SCOs;
142 -- Write SCO information to the ALI file using routines in Lib.Util
143
144 ----------
145 -- dsco --
146 ----------
147
148 procedure dsco is
149 begin
150 -- Dump SCO unit table
151
152 Write_Line ("SCO Unit Table");
153 Write_Line ("--------------");
154
155 for Index in 1 .. SCO_Unit_Table.Last loop
156 declare
157 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
158
159 begin
160 Write_Str (" ");
161 Write_Int (Int (Index));
162 Write_Str (". Dep_Num = ");
163 Write_Int (Int (UTE.Dep_Num));
164 Write_Str (" From = ");
165 Write_Int (Int (UTE.From));
166 Write_Str (" To = ");
167 Write_Int (Int (UTE.To));
168
169 Write_Str (" File_Name = """);
170
171 if UTE.File_Name /= null then
172 Write_Str (UTE.File_Name.all);
173 end if;
174
175 Write_Char ('"');
176 Write_Eol;
177 end;
178 end loop;
179
180 -- Dump SCO Unit number table if it contains any entries
181
182 if SCO_Unit_Number_Table.Last >= 1 then
183 Write_Eol;
184 Write_Line ("SCO Unit Number Table");
185 Write_Line ("---------------------");
186
187 for Index in 1 .. SCO_Unit_Number_Table.Last loop
188 Write_Str (" ");
189 Write_Int (Int (Index));
190 Write_Str (". Unit_Number = ");
191 Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
192 Write_Eol;
193 end loop;
194 end if;
195
196 -- Dump SCO table itself
197
198 Write_Eol;
199 Write_Line ("SCO Table");
200 Write_Line ("---------");
201
202 for Index in 1 .. SCO_Table.Last loop
203 declare
204 T : SCO_Table_Entry renames SCO_Table.Table (Index);
205
206 begin
207 Write_Str (" ");
208 Write_Int (Index);
209 Write_Char ('.');
210
211 if T.C1 /= ' ' then
212 Write_Str (" C1 = '");
213 Write_Char (T.C1);
214 Write_Char (''');
215 end if;
216
217 if T.C2 /= ' ' then
218 Write_Str (" C2 = '");
219 Write_Char (T.C2);
220 Write_Char (''');
221 end if;
222
223 if T.From /= No_Source_Location then
224 Write_Str (" From = ");
225 Write_Int (Int (T.From.Line));
226 Write_Char (':');
227 Write_Int (Int (T.From.Col));
228 end if;
229
230 if T.To /= No_Source_Location then
231 Write_Str (" To = ");
232 Write_Int (Int (T.To.Line));
233 Write_Char (':');
234 Write_Int (Int (T.To.Col));
235 end if;
236
237 if T.Last then
238 Write_Str (" True");
239 else
240 Write_Str (" False");
241 end if;
242
243 Write_Eol;
244 end;
245 end loop;
246 end dsco;
247
248 -----------
249 -- Equal --
250 -----------
251
252 function Equal (F1, F2 : Source_Ptr) return Boolean is
253 begin
254 return F1 = F2;
255 end Equal;
256
257 ------------------
258 -- Has_Decision --
259 ------------------
260
261 function Has_Decision (N : Node_Id) return Boolean is
262
263 function Check_Node (N : Node_Id) return Traverse_Result;
264
265 ----------------
266 -- Check_Node --
267 ----------------
268
269 function Check_Node (N : Node_Id) return Traverse_Result is
270 begin
271 if Is_Logical_Operator (N) then
272 return Abandon;
273 else
274 return OK;
275 end if;
276 end Check_Node;
277
278 function Traverse is new Traverse_Func (Check_Node);
279
280 -- Start of processing for Has_Decision
281
282 begin
283 return Traverse (N) = Abandon;
284 end Has_Decision;
285
286 ----------
287 -- Hash --
288 ----------
289
290 function Hash (F : Source_Ptr) return Header_Num is
291 begin
292 return Header_Num (Nat (F) mod 997);
293 end Hash;
294
295 ----------------
296 -- Initialize --
297 ----------------
298
299 procedure Initialize is
300 begin
301 SCO_Unit_Number_Table.Init;
302
303 -- Set dummy 0'th entry in place for sort
304
305 SCO_Unit_Number_Table.Increment_Last;
306 end Initialize;
307
308 -------------------------
309 -- Is_Logical_Operator --
310 -------------------------
311
312 function Is_Logical_Operator (N : Node_Id) return Boolean is
313 begin
314 return Nkind_In (N, N_Op_Not,
315 N_And_Then,
316 N_Or_Else);
317 end Is_Logical_Operator;
318
319 -----------------------
320 -- Process_Decisions --
321 -----------------------
322
323 -- Version taking a list
324
325 procedure Process_Decisions
326 (L : List_Id;
327 T : Character;
328 Pragma_Sloc : Source_Ptr)
329 is
330 N : Node_Id;
331 begin
332 if L /= No_List then
333 N := First (L);
334 while Present (N) loop
335 Process_Decisions (N, T, Pragma_Sloc);
336 Next (N);
337 end loop;
338 end if;
339 end Process_Decisions;
340
341 -- Version taking a node
342
343 Current_Pragma_Sloc : Source_Ptr := No_Location;
344 -- While processing a pragma, this is set to the sloc of the N_Pragma node
345
346 procedure Process_Decisions
347 (N : Node_Id;
348 T : Character;
349 Pragma_Sloc : Source_Ptr)
350 is
351 Mark : Nat;
352 -- This is used to mark the location of a decision sequence in the SCO
353 -- table. We use it for backing out a simple decision in an expression
354 -- context that contains only NOT operators.
355
356 X_Not_Decision : Boolean;
357 -- This flag keeps track of whether a decision sequence in the SCO table
358 -- contains only NOT operators, and is for an expression context (T=X).
359 -- The flag will be set False if T is other than X, or if an operator
360 -- other than NOT is in the sequence.
361
362 function Process_Node (N : Node_Id) return Traverse_Result;
363 -- Processes one node in the traversal, looking for logical operators,
364 -- and if one is found, outputs the appropriate table entries.
365
366 procedure Output_Decision_Operand (N : Node_Id);
367 -- The node N is the top level logical operator of a decision, or it is
368 -- one of the operands of a logical operator belonging to a single
369 -- complex decision. This routine outputs the sequence of table entries
370 -- corresponding to the node. Note that we do not process the sub-
371 -- operands to look for further decisions, that processing is done in
372 -- Process_Decision_Operand, because we can't get decisions mixed up in
373 -- the global table. Call has no effect if N is Empty.
374
375 procedure Output_Element (N : Node_Id);
376 -- Node N is an operand of a logical operator that is not itself a
377 -- logical operator, or it is a simple decision. This routine outputs
378 -- the table entry for the element, with C1 set to ' '. Last is set
379 -- False, and an entry is made in the condition hash table.
380
381 procedure Output_Header (T : Character);
382 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
383 -- PRAGMA, and 'X' for the expression case.
384
385 procedure Process_Decision_Operand (N : Node_Id);
386 -- This is called on node N, the top level node of a decision, or on one
387 -- of its operands or suboperands after generating the full output for
388 -- the complex decision. It process the suboperands of the decision
389 -- looking for nested decisions.
390
391 -----------------------------
392 -- Output_Decision_Operand --
393 -----------------------------
394
395 procedure Output_Decision_Operand (N : Node_Id) is
396 C : Character;
397 L : Node_Id;
398
399 begin
400 if No (N) then
401 return;
402
403 -- Logical operator
404
405 elsif Is_Logical_Operator (N) then
406 if Nkind (N) = N_Op_Not then
407 C := '!';
408 L := Empty;
409
410 else
411 L := Left_Opnd (N);
412
413 if Nkind_In (N, N_Op_Or, N_Or_Else) then
414 C := '|';
415 else
416 C := '&';
417 end if;
418 end if;
419
420 Set_Table_Entry
421 (C1 => C,
422 C2 => ' ',
423 From => Sloc (N),
424 To => No_Location,
425 Last => False);
426
427 Output_Decision_Operand (L);
428 Output_Decision_Operand (Right_Opnd (N));
429
430 -- Not a logical operator
431
432 else
433 Output_Element (N);
434 end if;
435 end Output_Decision_Operand;
436
437 --------------------
438 -- Output_Element --
439 --------------------
440
441 procedure Output_Element (N : Node_Id) is
442 FSloc : Source_Ptr;
443 LSloc : Source_Ptr;
444 begin
445 Sloc_Range (N, FSloc, LSloc);
446 Set_Table_Entry
447 (C1 => ' ',
448 C2 => 'c',
449 From => FSloc,
450 To => LSloc,
451 Last => False);
452 Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last);
453 end Output_Element;
454
455 -------------------
456 -- Output_Header --
457 -------------------
458
459 procedure Output_Header (T : Character) is
460 Loc : Source_Ptr := No_Location;
461 -- Node whose sloc is used for the decision
462
463 begin
464 case T is
465 when 'I' | 'E' | 'W' =>
466
467 -- For IF, EXIT, WHILE, the token SLOC can be found from
468 -- the SLOC of the parent of the expression.
469
470 Loc := Sloc (Parent (N));
471
472 when 'G' | 'P' =>
473
474 -- For entry, the token sloc is from the N_Entry_Body. For
475 -- PRAGMA, we must get the location from the pragma node.
476 -- Argument N is the pragma argument, and we have to go up two
477 -- levels (through the pragma argument association) to get to
478 -- the pragma node itself.
479
480 Loc := Sloc (Parent (Parent (N)));
481
482 when 'X' =>
483
484 -- For an expression, no Sloc
485
486 null;
487
488 -- No other possibilities
489
490 when others =>
491 raise Program_Error;
492 end case;
493
494 Set_Table_Entry
495 (C1 => T,
496 C2 => ' ',
497 From => Loc,
498 To => No_Location,
499 Last => False,
500 Pragma_Sloc => Pragma_Sloc);
501 end Output_Header;
502
503 ------------------------------
504 -- Process_Decision_Operand --
505 ------------------------------
506
507 procedure Process_Decision_Operand (N : Node_Id) is
508 begin
509 if Is_Logical_Operator (N) then
510 if Nkind (N) /= N_Op_Not then
511 Process_Decision_Operand (Left_Opnd (N));
512 X_Not_Decision := False;
513 end if;
514
515 Process_Decision_Operand (Right_Opnd (N));
516
517 else
518 Process_Decisions (N, 'X', Pragma_Sloc);
519 end if;
520 end Process_Decision_Operand;
521
522 ------------------
523 -- Process_Node --
524 ------------------
525
526 function Process_Node (N : Node_Id) return Traverse_Result is
527 begin
528 case Nkind (N) is
529
530 -- Logical operators, output table entries and then process
531 -- operands recursively to deal with nested conditions.
532
533 when N_And_Then |
534 N_Or_Else |
535 N_Op_Not =>
536
537 declare
538 T : Character;
539
540 begin
541 -- If outer level, then type comes from call, otherwise it
542 -- is more deeply nested and counts as X for expression.
543
544 if N = Process_Decisions.N then
545 T := Process_Decisions.T;
546 else
547 T := 'X';
548 end if;
549
550 -- Output header for sequence
551
552 X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
553 Mark := SCO_Table.Last;
554 Output_Header (T);
555
556 -- Output the decision
557
558 Output_Decision_Operand (N);
559
560 -- If the decision was in an expression context (T = 'X')
561 -- and contained only NOT operators, then we don't output
562 -- it, so delete it.
563
564 if X_Not_Decision then
565 SCO_Table.Set_Last (Mark);
566
567 -- Otherwise, set Last in last table entry to mark end
568
569 else
570 SCO_Table.Table (SCO_Table.Last).Last := True;
571 end if;
572
573 -- Process any embedded decisions
574
575 Process_Decision_Operand (N);
576 return Skip;
577 end;
578
579 -- Case expression
580
581 when N_Case_Expression =>
582 return OK; -- ???
583
584 -- Conditional expression, processed like an if statement
585
586 when N_Conditional_Expression =>
587 declare
588 Cond : constant Node_Id := First (Expressions (N));
589 Thnx : constant Node_Id := Next (Cond);
590 Elsx : constant Node_Id := Next (Thnx);
591 begin
592 Process_Decisions (Cond, 'I', Pragma_Sloc);
593 Process_Decisions (Thnx, 'X', Pragma_Sloc);
594 Process_Decisions (Elsx, 'X', Pragma_Sloc);
595 return Skip;
596 end;
597
598 -- All other cases, continue scan
599
600 when others =>
601 return OK;
602
603 end case;
604 end Process_Node;
605
606 procedure Traverse is new Traverse_Proc (Process_Node);
607
608 -- Start of processing for Process_Decisions
609
610 begin
611 if No (N) then
612 return;
613 end if;
614
615 -- See if we have simple decision at outer level and if so then
616 -- generate the decision entry for this simple decision. A simple
617 -- decision is a boolean expression (which is not a logical operator
618 -- or short circuit form) appearing as the operand of an IF, WHILE,
619 -- EXIT WHEN, or special PRAGMA construct.
620
621 if T /= 'X' and then not Is_Logical_Operator (N) then
622 Output_Header (T);
623 Output_Element (N);
624
625 -- Change Last in last table entry to True to mark end of
626 -- sequence, which is this case is only one element long.
627
628 SCO_Table.Table (SCO_Table.Last).Last := True;
629 end if;
630
631 Traverse (N);
632 end Process_Decisions;
633
634 -----------
635 -- pscos --
636 -----------
637
638 procedure pscos is
639
640 procedure Write_Info_Char (C : Character) renames Write_Char;
641 -- Write one character;
642
643 procedure Write_Info_Initiate (Key : Character) renames Write_Char;
644 -- Start new one and write one character;
645
646 procedure Write_Info_Nat (N : Nat);
647 -- Write value of N
648
649 procedure Write_Info_Terminate renames Write_Eol;
650 -- Terminate current line
651
652 --------------------
653 -- Write_Info_Nat --
654 --------------------
655
656 procedure Write_Info_Nat (N : Nat) is
657 begin
658 Write_Int (N);
659 end Write_Info_Nat;
660
661 procedure Debug_Put_SCOs is new Put_SCOs;
662
663 -- Start of processing for pscos
664
665 begin
666 Debug_Put_SCOs;
667 end pscos;
668
669 ----------------
670 -- SCO_Output --
671 ----------------
672
673 procedure SCO_Output is
674 begin
675 if Debug_Flag_Dot_OO then
676 dsco;
677 end if;
678
679 -- Sort the unit tables based on dependency numbers
680
681 Unit_Table_Sort : declare
682
683 function Lt (Op1, Op2 : Natural) return Boolean;
684 -- Comparison routine for sort call
685
686 procedure Move (From : Natural; To : Natural);
687 -- Move routine for sort call
688
689 --------
690 -- Lt --
691 --------
692
693 function Lt (Op1, Op2 : Natural) return Boolean is
694 begin
695 return
696 Dependency_Num
697 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
698 <
699 Dependency_Num
700 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
701 end Lt;
702
703 ----------
704 -- Move --
705 ----------
706
707 procedure Move (From : Natural; To : Natural) is
708 begin
709 SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
710 SCO_Unit_Table.Table (SCO_Unit_Index (From));
711 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
712 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
713 end Move;
714
715 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
716
717 -- Start of processing for Unit_Table_Sort
718
719 begin
720 Sorting.Sort (Integer (SCO_Unit_Table.Last));
721 end Unit_Table_Sort;
722
723 -- Loop through entries in the unit table to set file name and
724 -- dependency number entries.
725
726 for J in 1 .. SCO_Unit_Table.Last loop
727 declare
728 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
729 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
730 begin
731 Get_Name_String (Reference_Name (Source_Index (U)));
732 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
733 UTE.Dep_Num := Dependency_Num (U);
734 end;
735 end loop;
736
737 -- Now the tables are all setup for output to the ALI file
738
739 Write_SCOs_To_ALI_File;
740 end SCO_Output;
741
742 -------------------------
743 -- SCO_Pragma_Disabled --
744 -------------------------
745
746 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
747 Index : Nat;
748
749 begin
750 if Loc = No_Location then
751 return False;
752 end if;
753
754 Index := Condition_Pragma_Hash_Table.Get (Loc);
755
756 -- The test here for zero is to deal with possible previous errors, and
757 -- for the case of pragma statement SCOs, for which we always set the
758 -- Pragma_Sloc even if the particular pragma cannot be specifically
759 -- disabled.
760
761 if Index /= 0 then
762 declare
763 T : SCO_Table_Entry renames SCO_Table.Table (Index);
764 begin
765 pragma Assert (T.C1 = 'S' or else T.C1 = 's');
766 return T.C2 = 'p';
767 end;
768
769 else
770 return False;
771 end if;
772 end SCO_Pragma_Disabled;
773
774 ----------------
775 -- SCO_Record --
776 ----------------
777
778 procedure SCO_Record (U : Unit_Number_Type) is
779 Lu : Node_Id;
780 From : Nat;
781
782 begin
783 -- Ignore call if not generating code and generating SCO's
784
785 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
786 return;
787 end if;
788
789 -- Ignore call if this unit already recorded
790
791 for J in 1 .. SCO_Unit_Number_Table.Last loop
792 if U = SCO_Unit_Number_Table.Table (J) then
793 return;
794 end if;
795 end loop;
796
797 -- Otherwise record starting entry
798
799 From := SCO_Table.Last + 1;
800
801 -- Get Unit (checking case of subunit)
802
803 Lu := Unit (Cunit (U));
804
805 if Nkind (Lu) = N_Subunit then
806 Lu := Proper_Body (Lu);
807 end if;
808
809 -- Traverse the unit
810
811 case Nkind (Lu) is
812 when N_Protected_Body =>
813 Traverse_Protected_Body (Lu);
814
815 when N_Subprogram_Body | N_Task_Body =>
816 Traverse_Subprogram_Or_Task_Body (Lu);
817
818 when N_Subprogram_Declaration =>
819 Traverse_Subprogram_Declaration (Lu);
820
821 when N_Package_Declaration =>
822 Traverse_Package_Declaration (Lu);
823
824 when N_Package_Body =>
825 Traverse_Package_Body (Lu);
826
827 when N_Generic_Package_Declaration =>
828 Traverse_Generic_Package_Declaration (Lu);
829
830 when N_Generic_Instantiation =>
831 Traverse_Generic_Instantiation (Lu);
832
833 when others =>
834
835 -- All other cases of compilation units (e.g. renamings), generate
836 -- no SCO information.
837
838 null;
839 end case;
840
841 -- Make entry for new unit in unit tables, we will fill in the file
842 -- name and dependency numbers later.
843
844 SCO_Unit_Table.Append (
845 (Dep_Num => 0,
846 File_Name => null,
847 From => From,
848 To => SCO_Table.Last));
849
850 SCO_Unit_Number_Table.Append (U);
851 end SCO_Record;
852
853 -----------------------
854 -- Set_SCO_Condition --
855 -----------------------
856
857 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
858 Orig : constant Node_Id := Original_Node (Cond);
859 Index : Nat;
860 Start : Source_Ptr;
861 Dummy : Source_Ptr;
862
863 Constant_Condition_Code : constant array (Boolean) of Character :=
864 (False => 'f', True => 't');
865 begin
866 Sloc_Range (Orig, Start, Dummy);
867 Index := Condition_Pragma_Hash_Table.Get (Start);
868
869 -- The test here for zero is to deal with possible previous errors
870
871 if Index /= 0 then
872 pragma Assert (SCO_Table.Table (Index).C1 = ' ');
873 SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val);
874 end if;
875 end Set_SCO_Condition;
876
877 ----------------------------
878 -- Set_SCO_Pragma_Enabled --
879 ----------------------------
880
881 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
882 Index : Nat;
883
884 begin
885 -- Note: the reason we use the Sloc value as the key is that in the
886 -- generic case, the call to this procedure is made on a copy of the
887 -- original node, so we can't use the Node_Id value.
888
889 Index := Condition_Pragma_Hash_Table.Get (Loc);
890
891 -- The test here for zero is to deal with possible previous errors
892
893 if Index /= 0 then
894 declare
895 T : SCO_Table_Entry renames SCO_Table.Table (Index);
896
897 begin
898 -- Called multiple times for the same sloc (need to allow for
899 -- C2 = 'P') ???
900
901 pragma Assert ((T.C1 = 'S' or else T.C1 = 's')
902 and then
903 (T.C2 = 'p' or else T.C2 = 'P'));
904 T.C2 := 'P';
905 end;
906 end if;
907 end Set_SCO_Pragma_Enabled;
908
909 ---------------------
910 -- Set_Table_Entry --
911 ---------------------
912
913 procedure Set_Table_Entry
914 (C1 : Character;
915 C2 : Character;
916 From : Source_Ptr;
917 To : Source_Ptr;
918 Last : Boolean;
919 Pragma_Sloc : Source_Ptr := No_Location)
920 is
921 function To_Source_Location (S : Source_Ptr) return Source_Location;
922 -- Converts Source_Ptr value to Source_Location (line/col) format
923
924 ------------------------
925 -- To_Source_Location --
926 ------------------------
927
928 function To_Source_Location (S : Source_Ptr) return Source_Location is
929 begin
930 if S = No_Location then
931 return No_Source_Location;
932 else
933 return
934 (Line => Get_Logical_Line_Number (S),
935 Col => Get_Column_Number (S));
936 end if;
937 end To_Source_Location;
938
939 -- Start of processing for Set_Table_Entry
940
941 begin
942 Add_SCO
943 (C1 => C1,
944 C2 => C2,
945 From => To_Source_Location (From),
946 To => To_Source_Location (To),
947 Last => Last,
948 Pragma_Sloc => Pragma_Sloc);
949 end Set_Table_Entry;
950
951 -----------------------------------------
952 -- Traverse_Declarations_Or_Statements --
953 -----------------------------------------
954
955 -- Tables used by Traverse_Declarations_Or_Statements for temporarily
956 -- holding statement and decision entries. These are declared globally
957 -- since they are shared by recursive calls to this procedure.
958
959 type SC_Entry is record
960 From : Source_Ptr;
961 To : Source_Ptr;
962 Typ : Character;
963 end record;
964 -- Used to store a single entry in the following table, From:To represents
965 -- the range of entries in the CS line entry, and typ is the type, with
966 -- space meaning that no type letter will accompany the entry.
967
968 package SC is new Table.Table (
969 Table_Component_Type => SC_Entry,
970 Table_Index_Type => Nat,
971 Table_Low_Bound => 1,
972 Table_Initial => 1000,
973 Table_Increment => 200,
974 Table_Name => "SCO_SC");
975 -- Used to store statement components for a CS entry to be output
976 -- as a result of the call to this procedure. SC.Last is the last
977 -- entry stored, so the current statement sequence is represented
978 -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on
979 -- entry to each recursive call to the routine.
980 --
981 -- Extend_Statement_Sequence adds an entry to this array, and then
982 -- Set_Statement_Entry clears the entries starting with SC_First,
983 -- copying these entries to the main SCO output table. The reason that
984 -- we do the temporary caching of results in this array is that we want
985 -- the SCO table entries for a given CS line to be contiguous, and the
986 -- processing may output intermediate entries such as decision entries.
987
988 type SD_Entry is record
989 Nod : Node_Id;
990 Lst : List_Id;
991 Typ : Character;
992 Plo : Source_Ptr;
993 end record;
994 -- Used to store a single entry in the following table. Nod is the node to
995 -- be searched for decisions for the case of Process_Decisions_Defer with a
996 -- node argument (with Lst set to No_List. Lst is the list to be searched
997 -- for decisions for the case of Process_Decisions_Defer with a List
998 -- argument (in which case Nod is set to Empty). Plo is the sloc of the
999 -- enclosing pragma, if any.
1000
1001 package SD is new Table.Table (
1002 Table_Component_Type => SD_Entry,
1003 Table_Index_Type => Nat,
1004 Table_Low_Bound => 1,
1005 Table_Initial => 1000,
1006 Table_Increment => 200,
1007 Table_Name => "SCO_SD");
1008 -- Used to store possible decision information. Instead of calling the
1009 -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
1010 -- which simply stores the arguments in this table. Then when we clear
1011 -- out a statement sequence using Set_Statement_Entry, after generating
1012 -- the CS lines for the statements, the entries in this table result in
1013 -- calls to Process_Decision. The reason for doing things this way is to
1014 -- ensure that decisions are output after the CS line for the statements
1015 -- in which the decisions occur.
1016
1017 procedure Traverse_Declarations_Or_Statements (L : List_Id) is
1018 N : Node_Id;
1019 Dummy : Source_Ptr;
1020
1021 SC_First : constant Nat := SC.Last + 1;
1022 SD_First : constant Nat := SD.Last + 1;
1023 -- Record first entries used in SC/SD at this recursive level
1024
1025 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
1026 -- Extend the current statement sequence to encompass the node N. Typ
1027 -- is the letter that identifies the type of statement/declaration that
1028 -- is being added to the sequence.
1029
1030 procedure Extend_Statement_Sequence
1031 (From : Node_Id;
1032 To : Node_Id;
1033 Typ : Character);
1034 -- This version extends the current statement sequence with an entry
1035 -- that starts with the first token of From, and ends with the last
1036 -- token of To. It is used for example in a CASE statement to cover
1037 -- the range from the CASE token to the last token of the expression.
1038
1039 procedure Set_Statement_Entry;
1040 -- If Start is No_Location, does nothing, otherwise outputs a SCO_Table
1041 -- statement entry for the range Start-Stop and then sets both Start
1042 -- and Stop to No_Location.
1043 -- What are Start and Stop??? This comment seems completely unrelated
1044 -- to the implementation!???
1045 -- Unconditionally sets Term to True. What is Term???
1046 -- This is called when we find a statement or declaration that generates
1047 -- its own table entry, so that we must end the current statement
1048 -- sequence.
1049
1050 procedure Process_Decisions_Defer (N : Node_Id; T : Character);
1051 pragma Inline (Process_Decisions_Defer);
1052 -- This routine is logically the same as Process_Decisions, except that
1053 -- the arguments are saved in the SD table, for later processing when
1054 -- Set_Statement_Entry is called, which goes through the saved entries
1055 -- making the corresponding calls to Process_Decision.
1056
1057 procedure Process_Decisions_Defer (L : List_Id; T : Character);
1058 pragma Inline (Process_Decisions_Defer);
1059 -- Same case for list arguments, deferred call to Process_Decisions
1060
1061 -------------------------
1062 -- Set_Statement_Entry --
1063 -------------------------
1064
1065 procedure Set_Statement_Entry is
1066 C1 : Character;
1067 SC_Last : constant Int := SC.Last;
1068 SD_Last : constant Int := SD.Last;
1069
1070 begin
1071 -- Output statement entries from saved entries in SC table
1072
1073 for J in SC_First .. SC_Last loop
1074 if J = SC_First then
1075 C1 := 'S';
1076 else
1077 C1 := 's';
1078 end if;
1079
1080 declare
1081 SCE : SC_Entry renames SC.Table (J);
1082 Pragma_Sloc : Source_Ptr := No_Location;
1083 begin
1084 -- For the case of a statement SCO for a pragma controlled by
1085 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
1086 -- those of any nested decision) is emitted only if the pragma
1087 -- is enabled.
1088
1089 if SCE.Typ = 'p' then
1090 Pragma_Sloc := SCE.From;
1091 Condition_Pragma_Hash_Table.Set
1092 (Pragma_Sloc, SCO_Table.Last + 1);
1093 end if;
1094
1095 Set_Table_Entry
1096 (C1 => C1,
1097 C2 => SCE.Typ,
1098 From => SCE.From,
1099 To => SCE.To,
1100 Last => (J = SC_Last),
1101 Pragma_Sloc => Pragma_Sloc);
1102 end;
1103 end loop;
1104
1105 -- Clear out used section of SC table
1106
1107 SC.Set_Last (SC_First - 1);
1108
1109 -- Output any embedded decisions
1110
1111 for J in SD_First .. SD_Last loop
1112 declare
1113 SDE : SD_Entry renames SD.Table (J);
1114 begin
1115 if Present (SDE.Nod) then
1116 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
1117 else
1118 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
1119 end if;
1120 end;
1121 end loop;
1122
1123 -- Clear out used section of SD table
1124
1125 SD.Set_Last (SD_First - 1);
1126 end Set_Statement_Entry;
1127
1128 -------------------------------
1129 -- Extend_Statement_Sequence --
1130 -------------------------------
1131
1132 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1133 F : Source_Ptr;
1134 T : Source_Ptr;
1135 begin
1136 Sloc_Range (N, F, T);
1137 SC.Append ((F, T, Typ));
1138 end Extend_Statement_Sequence;
1139
1140 procedure Extend_Statement_Sequence
1141 (From : Node_Id;
1142 To : Node_Id;
1143 Typ : Character)
1144 is
1145 F : Source_Ptr;
1146 T : Source_Ptr;
1147 begin
1148 Sloc_Range (From, F, Dummy);
1149 Sloc_Range (To, Dummy, T);
1150 SC.Append ((F, T, Typ));
1151 end Extend_Statement_Sequence;
1152
1153 -----------------------------
1154 -- Process_Decisions_Defer --
1155 -----------------------------
1156
1157 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1158 begin
1159 SD.Append ((N, No_List, T, Current_Pragma_Sloc));
1160 end Process_Decisions_Defer;
1161
1162 procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1163 begin
1164 SD.Append ((Empty, L, T, Current_Pragma_Sloc));
1165 end Process_Decisions_Defer;
1166
1167 -- Start of processing for Traverse_Declarations_Or_Statements
1168
1169 begin
1170 if Is_Non_Empty_List (L) then
1171
1172 -- Loop through statements or declarations
1173
1174 N := First (L);
1175 while Present (N) loop
1176
1177 -- Initialize or extend current statement sequence. Note that for
1178 -- special cases such as IF and Case statements we will modify
1179 -- the range to exclude internal statements that should not be
1180 -- counted as part of the current statement sequence.
1181
1182 case Nkind (N) is
1183
1184 -- Package declaration
1185
1186 when N_Package_Declaration =>
1187 Set_Statement_Entry;
1188 Traverse_Package_Declaration (N);
1189
1190 -- Generic package declaration
1191
1192 when N_Generic_Package_Declaration =>
1193 Set_Statement_Entry;
1194 Traverse_Generic_Package_Declaration (N);
1195
1196 -- Package body
1197
1198 when N_Package_Body =>
1199 Set_Statement_Entry;
1200 Traverse_Package_Body (N);
1201
1202 -- Subprogram declaration
1203
1204 when N_Subprogram_Declaration =>
1205 Process_Decisions_Defer
1206 (Parameter_Specifications (Specification (N)), 'X');
1207 Set_Statement_Entry;
1208
1209 -- Generic subprogram declaration
1210
1211 when N_Generic_Subprogram_Declaration =>
1212 Process_Decisions_Defer
1213 (Generic_Formal_Declarations (N), 'X');
1214 Process_Decisions_Defer
1215 (Parameter_Specifications (Specification (N)), 'X');
1216 Set_Statement_Entry;
1217
1218 -- Task or subprogram body
1219
1220 when N_Task_Body | N_Subprogram_Body =>
1221 Set_Statement_Entry;
1222 Traverse_Subprogram_Or_Task_Body (N);
1223
1224 -- Entry body
1225
1226 when N_Entry_Body =>
1227 declare
1228 Cond : constant Node_Id :=
1229 Condition (Entry_Body_Formal_Part (N));
1230
1231 begin
1232 Set_Statement_Entry;
1233
1234 if Present (Cond) then
1235 Process_Decisions_Defer (Cond, 'G');
1236 end if;
1237
1238 Traverse_Subprogram_Or_Task_Body (N);
1239 end;
1240
1241 -- Protected body
1242
1243 when N_Protected_Body =>
1244 Set_Statement_Entry;
1245 Traverse_Protected_Body (N);
1246
1247 -- Exit statement, which is an exit statement in the SCO sense,
1248 -- so it is included in the current statement sequence, but
1249 -- then it terminates this sequence. We also have to process
1250 -- any decisions in the exit statement expression.
1251
1252 when N_Exit_Statement =>
1253 Extend_Statement_Sequence (N, ' ');
1254 Process_Decisions_Defer (Condition (N), 'E');
1255 Set_Statement_Entry;
1256
1257 -- Label, which breaks the current statement sequence, but the
1258 -- label itself is not included in the next statement sequence,
1259 -- since it generates no code.
1260
1261 when N_Label =>
1262 Set_Statement_Entry;
1263
1264 -- Block statement, which breaks the current statement sequence
1265
1266 when N_Block_Statement =>
1267 Set_Statement_Entry;
1268 Traverse_Declarations_Or_Statements (Declarations (N));
1269 Traverse_Handled_Statement_Sequence
1270 (Handled_Statement_Sequence (N));
1271
1272 -- If statement, which breaks the current statement sequence,
1273 -- but we include the condition in the current sequence.
1274
1275 when N_If_Statement =>
1276 Extend_Statement_Sequence (N, Condition (N), 'I');
1277 Process_Decisions_Defer (Condition (N), 'I');
1278 Set_Statement_Entry;
1279
1280 -- Now we traverse the statements in the THEN part
1281
1282 Traverse_Declarations_Or_Statements (Then_Statements (N));
1283
1284 -- Loop through ELSIF parts if present
1285
1286 if Present (Elsif_Parts (N)) then
1287 declare
1288 Elif : Node_Id := First (Elsif_Parts (N));
1289
1290 begin
1291 while Present (Elif) loop
1292
1293 -- We generate a statement sequence for the
1294 -- construct "ELSIF condition", so that we have
1295 -- a statement for the resulting decisions.
1296
1297 Extend_Statement_Sequence
1298 (Elif, Condition (Elif), 'I');
1299 Process_Decisions_Defer (Condition (Elif), 'I');
1300 Set_Statement_Entry;
1301
1302 -- Traverse the statements in the ELSIF
1303
1304 Traverse_Declarations_Or_Statements
1305 (Then_Statements (Elif));
1306 Next (Elif);
1307 end loop;
1308 end;
1309 end if;
1310
1311 -- Finally traverse the ELSE statements if present
1312
1313 Traverse_Declarations_Or_Statements (Else_Statements (N));
1314
1315 -- Case statement, which breaks the current statement sequence,
1316 -- but we include the expression in the current sequence.
1317
1318 when N_Case_Statement =>
1319 Extend_Statement_Sequence (N, Expression (N), 'C');
1320 Process_Decisions_Defer (Expression (N), 'X');
1321 Set_Statement_Entry;
1322
1323 -- Process case branches
1324
1325 declare
1326 Alt : Node_Id;
1327 begin
1328 Alt := First (Alternatives (N));
1329 while Present (Alt) loop
1330 Traverse_Declarations_Or_Statements (Statements (Alt));
1331 Next (Alt);
1332 end loop;
1333 end;
1334
1335 -- Unconditional exit points, which are included in the current
1336 -- statement sequence, but then terminate it
1337
1338 when N_Requeue_Statement |
1339 N_Goto_Statement |
1340 N_Raise_Statement =>
1341 Extend_Statement_Sequence (N, ' ');
1342 Set_Statement_Entry;
1343
1344 -- Simple return statement. which is an exit point, but we
1345 -- have to process the return expression for decisions.
1346
1347 when N_Simple_Return_Statement =>
1348 Extend_Statement_Sequence (N, ' ');
1349 Process_Decisions_Defer (Expression (N), 'X');
1350 Set_Statement_Entry;
1351
1352 -- Extended return statement
1353
1354 when N_Extended_Return_Statement =>
1355 Extend_Statement_Sequence
1356 (N, Last (Return_Object_Declarations (N)), 'R');
1357 Process_Decisions_Defer
1358 (Return_Object_Declarations (N), 'X');
1359 Set_Statement_Entry;
1360
1361 Traverse_Handled_Statement_Sequence
1362 (Handled_Statement_Sequence (N));
1363
1364 -- Loop ends the current statement sequence, but we include
1365 -- the iteration scheme if present in the current sequence.
1366 -- But the body of the loop starts a new sequence, since it
1367 -- may not be executed as part of the current sequence.
1368
1369 when N_Loop_Statement =>
1370 if Present (Iteration_Scheme (N)) then
1371
1372 -- If iteration scheme present, extend the current
1373 -- statement sequence to include the iteration scheme
1374 -- and process any decisions it contains.
1375
1376 declare
1377 ISC : constant Node_Id := Iteration_Scheme (N);
1378
1379 begin
1380 -- While statement
1381
1382 if Present (Condition (ISC)) then
1383 Extend_Statement_Sequence (N, ISC, 'W');
1384 Process_Decisions_Defer (Condition (ISC), 'W');
1385
1386 -- For statement
1387
1388 else
1389 Extend_Statement_Sequence (N, ISC, 'F');
1390 Process_Decisions_Defer
1391 (Loop_Parameter_Specification (ISC), 'X');
1392 end if;
1393 end;
1394 end if;
1395
1396 Set_Statement_Entry;
1397 Traverse_Declarations_Or_Statements (Statements (N));
1398
1399 -- Pragma
1400
1401 when N_Pragma =>
1402
1403 -- Record sloc of pragma (pragmas don't nest)
1404
1405 pragma Assert (Current_Pragma_Sloc = No_Location);
1406 Current_Pragma_Sloc := Sloc (N);
1407
1408 -- Processing depends on the kind of pragma
1409
1410 declare
1411 Nam : constant Name_Id := Pragma_Name (N);
1412 Arg : Node_Id := First (Pragma_Argument_Associations (N));
1413 Typ : Character;
1414
1415 begin
1416 case Nam is
1417 when Name_Assert |
1418 Name_Check |
1419 Name_Precondition |
1420 Name_Postcondition =>
1421
1422 -- For Assert/Check/Precondition/Postcondition, we
1423 -- must generate a P entry for the decision. Note
1424 -- that this is done unconditionally at this stage.
1425 -- Output for disabled pragmas is suppressed later
1426 -- on, when we output the decision line in
1427 -- Put_SCOs, depending on marker sets by
1428 -- Set_SCO_Pragma_Disabled.
1429
1430 if Nam = Name_Check then
1431 Next (Arg);
1432 end if;
1433
1434 Process_Decisions_Defer (Expression (Arg), 'P');
1435 Typ := 'p';
1436
1437 when Name_Debug =>
1438 if Present (Arg) and then Present (Next (Arg)) then
1439
1440 -- Case of a dyadic pragma Debug: first argument
1441 -- is a P decision, any nested decision in the
1442 -- second argument is an X decision.
1443
1444 Process_Decisions_Defer (Expression (Arg), 'P');
1445 Next (Arg);
1446 end if;
1447
1448 Process_Decisions_Defer (Expression (Arg), 'X');
1449 Typ := 'p';
1450
1451 -- For all other pragmas, we generate decision entries
1452 -- for any embedded expressions, and the pragma is
1453 -- never disabled.
1454
1455 when others =>
1456 Process_Decisions_Defer (N, 'X');
1457 Typ := 'P';
1458 end case;
1459
1460 -- Add statement SCO
1461
1462 Extend_Statement_Sequence (N, Typ);
1463
1464 Current_Pragma_Sloc := No_Location;
1465 end;
1466
1467 -- Object declaration. Ignored if Prev_Ids is set, since the
1468 -- parser generates multiple instances of the whole declaration
1469 -- if there is more than one identifier declared, and we only
1470 -- want one entry in the SCO's, so we take the first, for which
1471 -- Prev_Ids is False.
1472
1473 when N_Object_Declaration =>
1474 if not Prev_Ids (N) then
1475 Extend_Statement_Sequence (N, 'o');
1476
1477 if Has_Decision (N) then
1478 Process_Decisions_Defer (N, 'X');
1479 end if;
1480 end if;
1481
1482 -- All other cases, which extend the current statement sequence
1483 -- but do not terminate it, even if they have nested decisions.
1484
1485 when others =>
1486
1487 -- Determine required type character code, or ASCII.NUL if
1488 -- no SCO should be generated for this node.
1489
1490 declare
1491 Typ : Character;
1492
1493 begin
1494 case Nkind (N) is
1495 when N_Full_Type_Declaration |
1496 N_Incomplete_Type_Declaration |
1497 N_Private_Type_Declaration |
1498 N_Private_Extension_Declaration =>
1499 Typ := 't';
1500
1501 when N_Subtype_Declaration =>
1502 Typ := 's';
1503
1504 when N_Renaming_Declaration =>
1505 Typ := 'r';
1506
1507 when N_Generic_Instantiation =>
1508 Typ := 'i';
1509
1510 when N_Representation_Clause |
1511 N_Use_Package_Clause |
1512 N_Use_Type_Clause =>
1513 Typ := ASCII.NUL;
1514
1515 when others =>
1516 Typ := ' ';
1517 end case;
1518
1519 if Typ /= ASCII.NUL then
1520 Extend_Statement_Sequence (N, Typ);
1521 end if;
1522 end;
1523
1524 -- Process any embedded decisions
1525
1526 if Has_Decision (N) then
1527 Process_Decisions_Defer (N, 'X');
1528 end if;
1529 end case;
1530
1531 Next (N);
1532 end loop;
1533
1534 Set_Statement_Entry;
1535 end if;
1536 end Traverse_Declarations_Or_Statements;
1537
1538 ------------------------------------
1539 -- Traverse_Generic_Instantiation --
1540 ------------------------------------
1541
1542 procedure Traverse_Generic_Instantiation (N : Node_Id) is
1543 First : Source_Ptr;
1544 Last : Source_Ptr;
1545
1546 begin
1547 -- First we need a statement entry to cover the instantiation
1548
1549 Sloc_Range (N, First, Last);
1550 Set_Table_Entry
1551 (C1 => 'S',
1552 C2 => ' ',
1553 From => First,
1554 To => Last,
1555 Last => True);
1556
1557 -- Now output any embedded decisions
1558
1559 Process_Decisions (N, 'X', No_Location);
1560 end Traverse_Generic_Instantiation;
1561
1562 ------------------------------------------
1563 -- Traverse_Generic_Package_Declaration --
1564 ------------------------------------------
1565
1566 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
1567 begin
1568 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
1569 Traverse_Package_Declaration (N);
1570 end Traverse_Generic_Package_Declaration;
1571
1572 -----------------------------------------
1573 -- Traverse_Handled_Statement_Sequence --
1574 -----------------------------------------
1575
1576 procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
1577 Handler : Node_Id;
1578
1579 begin
1580 -- For package bodies without a statement part, the parser adds an empty
1581 -- one, to normalize the representation. The null statement therein,
1582 -- which does not come from source, does not get a SCO.
1583
1584 if Present (N) and then Comes_From_Source (N) then
1585 Traverse_Declarations_Or_Statements (Statements (N));
1586
1587 if Present (Exception_Handlers (N)) then
1588 Handler := First (Exception_Handlers (N));
1589 while Present (Handler) loop
1590 Traverse_Declarations_Or_Statements (Statements (Handler));
1591 Next (Handler);
1592 end loop;
1593 end if;
1594 end if;
1595 end Traverse_Handled_Statement_Sequence;
1596
1597 ---------------------------
1598 -- Traverse_Package_Body --
1599 ---------------------------
1600
1601 procedure Traverse_Package_Body (N : Node_Id) is
1602 begin
1603 Traverse_Declarations_Or_Statements (Declarations (N));
1604 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1605 end Traverse_Package_Body;
1606
1607 ----------------------------------
1608 -- Traverse_Package_Declaration --
1609 ----------------------------------
1610
1611 procedure Traverse_Package_Declaration (N : Node_Id) is
1612 Spec : constant Node_Id := Specification (N);
1613 begin
1614 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
1615 Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
1616 end Traverse_Package_Declaration;
1617
1618 -----------------------------
1619 -- Traverse_Protected_Body --
1620 -----------------------------
1621
1622 procedure Traverse_Protected_Body (N : Node_Id) is
1623 begin
1624 Traverse_Declarations_Or_Statements (Declarations (N));
1625 end Traverse_Protected_Body;
1626
1627 --------------------------------------
1628 -- Traverse_Subprogram_Or_Task_Body --
1629 --------------------------------------
1630
1631 procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id) is
1632 begin
1633 Traverse_Declarations_Or_Statements (Declarations (N));
1634 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1635 end Traverse_Subprogram_Or_Task_Body;
1636
1637 -------------------------------------
1638 -- Traverse_Subprogram_Declaration --
1639 -------------------------------------
1640
1641 procedure Traverse_Subprogram_Declaration (N : Node_Id) is
1642 ADN : constant Node_Id := Aux_Decls_Node (Parent (N));
1643 begin
1644 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
1645 Traverse_Declarations_Or_Statements (Declarations (ADN));
1646 Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
1647 end Traverse_Subprogram_Declaration;
1648
1649 end Par_SCO;