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