OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [par_sco.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.