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, 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 Nlists;   use Nlists;
  31 with Opt;      use Opt;
  32 with Output;   use Output;
  33 with Sinfo;    use Sinfo;
  34 with Sinput;   use Sinput;
  35 with Table;
  36
  37 with GNAT.HTable;      use GNAT.HTable;
  38 with GNAT.Heap_Sort_G;
  39
  40 package body Par_SCO is
  41
  42    ---------------
  43    -- SCO_Table --
  44    ---------------
  45
  46    --  Internal table used to store recorded SCO values. Table is populated by
  47    --  calls to SCO_Record, and entries may be modified by Set_SCO_Condition.
  48
  49    type SCO_Table_Entry is record
  50       From : Source_Ptr;
  51       To   : Source_Ptr;
  52       C1   : Character;
  53       C2   : Character;
  54       Last : Boolean;
  55    end record;
  56
  57    package SCO_Table is new Table.Table (
  58      Table_Component_Type => SCO_Table_Entry,
  59      Table_Index_Type     => Nat,
  60      Table_Low_Bound      => 1,
  61      Table_Initial        => 500,
  62      Table_Increment      => 300,
  63      Table_Name           => "SCO_Table_Entry");
  64
  65    --  The SCO_Table_Entry values appear as follows:
  66
  67    --    Statements
  68    --      C1   = 'S'
  69    --      C2   = ' '
  70    --      From = starting sloc
  71    --      To   = ending sloc
  72    --      Last = unused
  73
  74    --    Exit
  75    --      C1   = 'T'
  76    --      C2   = ' '
  77    --      From = starting sloc
  78    --      To   = ending sloc
  79    --      Last = unused
  80
  81    --    Simple Decision
  82    --      C1   = 'I', 'E', 'W', 'X' (if/exit/while/expression)
  83    --      C2   = 'c', 't', or 'f'
  84    --      From = starting sloc
  85    --      To   = ending sloc
  86    --      Last = True
  87
  88    --    Complex Decision
  89    --      C1   = 'I', 'E', 'W', 'X' (if/exit/while/expression)
  90    --      C2   = ' '
  91    --      From = No_Location
  92    --      To   = No_Location
  93    --      Last = False
  94
  95    --    Operator
  96    --      C1   = '!', '^', '&', '|'
  97    --      C2   = ' '
  98    --      From = No_Location
  99    --      To   = No_Location
 100    --      Last = False
 101
 102    --    Element
 103    --      C1   = ' '
 104    --      C2   = 'c', 't', or 'f' (condition/true/false)
 105    --      From = starting sloc
 106    --      To   = ending sloc
 107    --      Last = False for all but the last entry, True for last entry
 108
 109    --    Note: the sequence starting with a decision, and continuing with
 110    --    operators and elements up to and including the first one labeled with
 111    --    Last=True, indicate the sequence to be output for a complex decision
 112    --    on a single CD decision line.
 113
 114    ----------------
 115    -- Unit Table --
 116    ----------------
 117
 118    --  This table keeps track of the units and the corresponding starting and
 119    --  ending indexes (From, To) in the SCO table. Note that entry zero is
 120    --  unused, it is for convenience in calling the sort routine.
 121
 122    type SCO_Unit_Table_Entry is record
 123       Unit : Unit_Number_Type;
 124       From : Nat;
 125       To   : Nat;
 126    end record;
 127
 128    package SCO_Unit_Table is new Table.Table (
 129      Table_Component_Type => SCO_Unit_Table_Entry,
 130      Table_Index_Type     => Int,
 131      Table_Low_Bound      => 0,
 132      Table_Initial        => 20,
 133      Table_Increment      => 200,
 134      Table_Name           => "SCO_Unit_Table_Entry");
 135
 136    --------------------------
 137    -- Condition Hash Table --
 138    --------------------------
 139
 140    --  We need to be able to get to conditions quickly for handling the calls
 141    --  to Set_SCO_Condition efficiently. For this purpose we identify the
 142    --  conditions in the table by their starting sloc, and use the following
 143    --  hash table to map from these starting sloc values to SCO_Table indexes.
 144
 145    type Header_Num is new Integer range 0 .. 996;
 146    --  Type for hash table headers
 147
 148    function Hash (F : Source_Ptr) return Header_Num;
 149    --  Function to Hash source pointer value
 150
 151    function Equal (F1, F2 : Source_Ptr) return Boolean;
 152    --  Function to test two keys for equality
 153
 154    package Condition_Hash_Table is new Simple_HTable
 155      (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
 156    --  The actual hash table
 157
 158    --------------------------
 159    -- Internal Subprograms --
 160    --------------------------
 161
 162    function Has_Decision (N : Node_Id) return Boolean;
 163    --  N is the node for a subexpression. Returns True if the subexpression
 164    --  contains a nested decision (i.e. either is a logical operator, or
 165    --  contains a logical operator in its subtree).
 166
 167    function Is_Logical_Operator (N : Node_Id) return Boolean;
 168    --  N is the node for a subexpression. This procedure just tests N to see
 169    --  if it is a logical operator (including short circuit conditions) and
 170    --  returns True if so, False otherwise, it does no other processing.
 171
 172    procedure Process_Decisions (N : Node_Id; T : Character);
 173    --  If N is Empty, has no effect. Otherwise scans the tree for the node N,
 174    --  to output any decisions it contains. T is one of IEWX (for context of
 175    --  expresion: if/while/when-exit/expression). If T is other than X, then
 176    --  the node is always a decision a decision is always present (at the very
 177    --  least a simple decision is present at the top level).
 178
 179    procedure Process_Decisions (L : List_Id; T : Character);
 180    --  Calls above procedure for each element of the list L
 181
 182    procedure Set_Table_Entry
 183      (C1   : Character;
 184       C2   : Character;
 185       From : Source_Ptr;
 186       To   : Source_Ptr;
 187       Last : Boolean);
 188    --  Append an entry to SCO_Table with fields set as per arguments
 189
 190    procedure Traverse_Declarations_Or_Statements  (L : List_Id);
 191    procedure Traverse_Generic_Package_Declaration (N : Node_Id);
 192    procedure Traverse_Handled_Statement_Sequence  (N : Node_Id);
 193    procedure Traverse_Package_Body                (N : Node_Id);
 194    procedure Traverse_Package_Declaration         (N : Node_Id);
 195    procedure Traverse_Subprogram_Body             (N : Node_Id);
 196    --  Traverse the corresponding construct, generating SCO table entries
 197
 198    procedure dsco;
 199    --  Debug routine to dump SCO table
 200
 201    ----------
 202    -- dsco --
 203    ----------
 204
 205    procedure dsco is
 206    begin
 207       Write_Line ("SCO Unit Table");
 208       Write_Line ("--------------");
 209
 210       for Index in SCO_Unit_Table.First .. SCO_Unit_Table.Last loop
 211          Write_Str ("  ");
 212          Write_Int (Index);
 213          Write_Str (".  Unit = ");
 214          Write_Int (Int (SCO_Unit_Table.Table (Index).Unit));
 215          Write_Str ("  From = ");
 216          Write_Int (Int (SCO_Unit_Table.Table (Index).From));
 217          Write_Str ("  To = ");
 218          Write_Int (Int (SCO_Unit_Table.Table (Index).To));
 219          Write_Eol;
 220       end loop;
 221
 222       Write_Eol;
 223       Write_Line ("SCO Table");
 224       Write_Line ("---------");
 225
 226       for Index in SCO_Table.First .. SCO_Table.Last loop
 227          declare
 228             T : SCO_Table_Entry renames SCO_Table.Table (Index);
 229
 230          begin
 231             Write_Str ("  ");
 232             Write_Int (Index);
 233             Write_Str (".  C1 = '");
 234             Write_Char (T.C1);
 235             Write_Str ("' C2 = '");
 236             Write_Char (T.C2);
 237             Write_Str ("' From = ");
 238             Write_Location (T.From);
 239             Write_Str ("  To = ");
 240             Write_Location (T.To);
 241             Write_Str (" Last = ");
 242
 243             if T.Last then
 244                Write_Str (" True");
 245             else
 246                Write_Str (" False");
 247             end if;
 248
 249             Write_Eol;
 250          end;
 251       end loop;
 252    end dsco;
 253
 254    -----------
 255    -- Equal --
 256    -----------
 257
 258    function Equal (F1, F2 : Source_Ptr) return Boolean is
 259    begin
 260       return F1 = F2;
 261    end Equal;
 262
 263    ------------------
 264    -- Has_Decision --
 265    ------------------
 266
 267    function Has_Decision (N : Node_Id) return Boolean is
 268
 269       function Check_Node (N : Node_Id) return Traverse_Result;
 270
 271       ----------------
 272       -- Check_Node --
 273       ----------------
 274
 275       function Check_Node (N : Node_Id) return Traverse_Result is
 276       begin
 277          if Is_Logical_Operator (N) then
 278             return Abandon;
 279          else
 280             return OK;
 281          end if;
 282       end Check_Node;
 283
 284       function Traverse is new Traverse_Func (Check_Node);
 285
 286    --  Start of processing for Has_Decision
 287
 288    begin
 289       return Traverse (N) = Abandon;
 290    end Has_Decision;
 291
 292    ----------
 293    -- Hash --
 294    ----------
 295
 296    function Hash (F : Source_Ptr) return Header_Num is
 297    begin
 298       return Header_Num (Nat (F) mod 997);
 299    end Hash;
 300
 301    ----------------
 302    -- Initialize --
 303    ----------------
 304
 305    procedure Initialize is
 306    begin
 307       SCO_Unit_Table.Init;
 308       SCO_Unit_Table.Increment_Last;
 309       SCO_Table.Init;
 310    end Initialize;
 311
 312    -------------------------
 313    -- Is_Logical_Operator --
 314    -------------------------
 315
 316    function Is_Logical_Operator (N : Node_Id) return Boolean is
 317    begin
 318       return Nkind_In (N, N_Op_And,
 319                           N_Op_Or,
 320                           N_Op_Xor,
 321                           N_Op_Not,
 322                           N_And_Then,
 323                           N_Or_Else);
 324    end Is_Logical_Operator;
 325
 326    -----------------------
 327    -- Process_Decisions --
 328    -----------------------
 329
 330    --  Version taking a list
 331
 332    procedure Process_Decisions (L : List_Id; T : Character) is
 333       N : Node_Id;
 334    begin
 335       if L /= No_List then
 336          N := First (L);
 337          while Present (N) loop
 338             Process_Decisions (N, T);
 339             Next (N);
 340          end loop;
 341       end if;
 342    end Process_Decisions;
 343
 344    --  Version taking a node
 345
 346    procedure Process_Decisions (N : Node_Id; T : Character) is
 347
 348       function Process_Node (N : Node_Id) return Traverse_Result;
 349       --  Processes one node in the traversal, looking for logical operators,
 350       --  and if one is found, outputs the appropriate table entries.
 351
 352       procedure Output_Decision_Operand (N : Node_Id);
 353       --  The node N is the top level logical operator of a decision, or it is
 354       --  one of the operands of a logical operator belonging to a single
 355       --  complex decision. This routine outputs the sequence of table entries
 356       --  corresponding to the node. Note that we do not process the sub-
 357       --  operands to look for further decisions, that processing is done in
 358       --  Process_Decision_Operand, because we can't get decisions mixed up in
 359       --  the global table. Call has no effect if N is Empty.
 360
 361       procedure Output_Element (N : Node_Id; T : Character);
 362       --  Node N is an operand of a logical operator that is not itself a
 363       --  logical operator, or it is a simple decision. This routine outputs
 364       --  the table entry for the element, with C1 set to T (' ' for one of
 365       --  the elements of a complex decision, or 'I'/'W'/'E' for a simple
 366       --  decision (from an IF, WHILE, or EXIT WHEN). Last is set to False,
 367       --  and an entry is made in the condition hash table.
 368
 369       procedure Process_Decision_Operand (N : Node_Id);
 370       --  This is called on node N, the top level node of a decision, or on one
 371       --  of its operands or suboperands after generating the full output for
 372       --  the complex decision. It process the suboperands of the decision
 373       --  looking for nested decisions.
 374
 375       -----------------------------
 376       -- Output_Decision_Operand --
 377       -----------------------------
 378
 379       procedure Output_Decision_Operand (N : Node_Id) is
 380          C : Character;
 381          L : Node_Id;
 382
 383          FSloc : Source_Ptr;
 384          LSloc : Source_Ptr;
 385
 386       begin
 387          if No (N) then
 388             return;
 389
 390          --  Logical operator
 391
 392          elsif Is_Logical_Operator (N) then
 393             if Nkind (N) = N_Op_Not then
 394                C := '!';
 395                L := Empty;
 396
 397             else
 398                L := Left_Opnd (N);
 399
 400                if Nkind (N) = N_Op_Xor then
 401                   C := '^';
 402                elsif Nkind_In (N, N_Op_Or, N_Or_Else) then
 403                   C := '|';
 404                else
 405                   C := '&';
 406                end if;
 407             end if;
 408
 409             Sloc_Range (N, FSloc, LSloc);
 410             Set_Table_Entry (C, ' ', FSloc, LSloc, False);
 411
 412             Output_Decision_Operand (L);
 413             Output_Decision_Operand (Right_Opnd (N));
 414
 415          --  Not a logical operator
 416
 417          else
 418             Output_Element (N, ' ');
 419          end if;
 420       end Output_Decision_Operand;
 421
 422       --------------------
 423       -- Output_Element --
 424       --------------------
 425
 426       procedure Output_Element (N : Node_Id; T : Character) is
 427          FSloc : Source_Ptr;
 428          LSloc : Source_Ptr;
 429       begin
 430          Sloc_Range (N, FSloc, LSloc);
 431          Set_Table_Entry (T, 'c', FSloc, LSloc, False);
 432          Condition_Hash_Table.Set (FSloc, SCO_Table.Last);
 433       end Output_Element;
 434
 435       ------------------------------
 436       -- Process_Decision_Operand --
 437       ------------------------------
 438
 439       procedure Process_Decision_Operand (N : Node_Id) is
 440       begin
 441          if Is_Logical_Operator (N) then
 442             if Nkind (N) /= N_Op_Not then
 443                Process_Decision_Operand (Left_Opnd (N));
 444             end if;
 445
 446             Process_Decision_Operand (Right_Opnd (N));
 447
 448          else
 449             Process_Decisions (N, 'X');
 450          end if;
 451       end Process_Decision_Operand;
 452
 453       ------------------
 454       -- Process_Node --
 455       ------------------
 456
 457       function Process_Node (N : Node_Id) return Traverse_Result is
 458       begin
 459          case Nkind (N) is
 460
 461                --  Logical operators and short circuit forms, output table
 462                --  entries and then process operands recursively to deal with
 463                --  nested conditions.
 464
 465             when N_And_Then                    |
 466                  N_Or_Else                     |
 467                  N_Op_And                      |
 468                  N_Op_Or                       |
 469                  N_Op_Xor                      |
 470                  N_Op_Not                      =>
 471
 472                declare
 473                   T : Character;
 474
 475                begin
 476                   --  If outer level, then type comes from call, otherwise it
 477                   --  is more deeply nested and counts as X for expression.
 478
 479                   if N = Process_Decisions.N then
 480                      T := Process_Decisions.T;
 481                   else
 482                      T := 'X';
 483                   end if;
 484
 485                   --  Output header for sequence
 486
 487                   Set_Table_Entry (T, ' ', No_Location, No_Location, False);
 488
 489                   --  Output the decision
 490
 491                   Output_Decision_Operand (N);
 492
 493                   --  Change Last in last table entry to True to mark end
 494
 495                   SCO_Table.Table (SCO_Table.Last).Last := True;
 496
 497                   --  Process any embedded decisions
 498
 499                   Process_Decision_Operand (N);
 500                   return Skip;
 501                end;
 502
 503             --  Conditional expression, processed like an if statement
 504
 505             when N_Conditional_Expression      =>
 506                declare
 507                   Cond : constant Node_Id := First (Expressions (N));
 508                   Thnx : constant Node_Id := Next (Cond);
 509                   Elsx : constant Node_Id := Next (Thnx);
 510                begin
 511                   Process_Decisions (Cond, 'I');
 512                   Process_Decisions (Thnx, 'X');
 513                   Process_Decisions (Elsx, 'X');
 514                   return Skip;
 515                end;
 516
 517             --  All other cases, continue scan
 518
 519             when others =>
 520                return OK;
 521
 522          end case;
 523       end Process_Node;
 524
 525       procedure Traverse is new Traverse_Proc (Process_Node);
 526
 527    --  Start of processing for Process_Decisions
 528
 529    begin
 530       if No (N) then
 531          return;
 532       end if;
 533
 534       --  See if we have simple decision at outer level and if so then
 535       --  generate the decision entry for this simple decision. A simple
 536       --  decision is a boolean expression (which is not a logical operator
 537       --  or short circuit form) appearing as the operand of an IF, WHILE
 538       --  or EXIT WHEN construct.
 539
 540       if T /= 'X' and then not Is_Logical_Operator (N) then
 541          Output_Element (N, T);
 542
 543          --  Change Last in last table entry to True to mark end of
 544          --  sequence, which is this case is only one element long.
 545
 546          SCO_Table.Table (SCO_Table.Last).Last := True;
 547       end if;
 548
 549       Traverse (N);
 550    end Process_Decisions;
 551
 552    ----------------
 553    -- SCO_Output --
 554    ----------------
 555
 556    procedure SCO_Output is
 557       Start : Nat;
 558       Stop  : Nat;
 559       U     : Unit_Number_Type;
 560
 561       procedure Output_Range (From : Source_Ptr; To : Source_Ptr);
 562       --  Outputs Sloc range in line:col-line:col format (for now we do not
 563       --  worry about generic instantiations???)
 564
 565       ------------------
 566       -- Output_Range --
 567       ------------------
 568
 569       procedure Output_Range (From : Source_Ptr; To : Source_Ptr) is
 570       begin
 571          Write_Info_Nat (Int (Get_Logical_Line_Number (From)));
 572          Write_Info_Char (':');
 573          Write_Info_Nat (Int (Get_Column_Number (From)));
 574          Write_Info_Char ('-');
 575          Write_Info_Nat (Int (Get_Logical_Line_Number (To)));
 576          Write_Info_Char (':');
 577          Write_Info_Nat (Int (Get_Column_Number (To)));
 578       end Output_Range;
 579
 580    --  Start of processing for SCO_Output
 581
 582    begin
 583       if Debug_Flag_Dot_OO then
 584          dsco;
 585       end if;
 586
 587       --  Sort the unit table
 588
 589       Unit_Table_Sort : declare
 590
 591          function Lt (Op1, Op2 : Natural) return Boolean;
 592          --  Comparison routine for sort call
 593
 594          procedure Move (From : Natural; To : Natural);
 595          --  Move routine for sort call
 596
 597          --------
 598          -- Lt --
 599          --------
 600
 601          function Lt (Op1, Op2 : Natural) return Boolean is
 602          begin
 603             return Dependency_Num (SCO_Unit_Table.Table (Nat (Op1)).Unit) <
 604                    Dependency_Num (SCO_Unit_Table.Table (Nat (Op2)).Unit);
 605          end Lt;
 606
 607          ----------
 608          -- Move --
 609          ----------
 610
 611          procedure Move (From : Natural; To : Natural) is
 612          begin
 613             SCO_Unit_Table.Table (Nat (To)) :=
 614               SCO_Unit_Table.Table (Nat (From));
 615          end Move;
 616
 617          package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
 618
 619       --  Start of processing for Unit_Table_Sort
 620
 621       begin
 622          Sorting.Sort (Integer (SCO_Unit_Table.Last));
 623       end Unit_Table_Sort;
 624
 625       --  Loop through entries in the unit table
 626
 627       for J in 1 .. SCO_Unit_Table.Last loop
 628          U := SCO_Unit_Table.Table (J).Unit;
 629
 630          --  Output header line preceded by blank line
 631
 632          Write_Info_Terminate;
 633          Write_Info_Initiate ('C');
 634          Write_Info_Char (' ');
 635          Write_Info_Nat (Dependency_Num (U));
 636          Write_Info_Char (' ');
 637          Write_Info_Name (Reference_Name (Source_Index (U)));
 638          Write_Info_Terminate;
 639
 640          Start := SCO_Unit_Table.Table (J).From;
 641          Stop  := SCO_Unit_Table.Table (J).To;
 642
 643          --  Loop through relevant entries in SCO table, outputting C lines
 644
 645          while Start <= Stop loop
 646             declare
 647                T : SCO_Table_Entry renames SCO_Table.Table (Start);
 648
 649             begin
 650                Write_Info_Initiate ('C');
 651                Write_Info_Char (T.C1);
 652
 653                case T.C1 is
 654
 655                   --  Statements, exit
 656
 657                   when 'S' | 'T' =>
 658                      Write_Info_Char (' ');
 659                      Output_Range (T.From, T.To);
 660
 661                      --  Decision
 662
 663                   when 'I' | 'E' | 'W' | 'X' =>
 664                      if T.C2 = ' ' then
 665                         Start := Start + 1;
 666                      end if;
 667
 668                      --  Loop through table entries for this decision
 669
 670                      loop
 671                         declare
 672                            T : SCO_Table_Entry renames SCO_Table.Table (Start);
 673
 674                         begin
 675                            Write_Info_Char (' ');
 676
 677                            if T.C1 = '!' or else
 678                              T.C1 = '^' or else
 679                              T.C1 = '&' or else
 680                              T.C1 = '|'
 681                            then
 682                               Write_Info_Char (T.C1);
 683
 684                            else
 685                               Write_Info_Char (T.C2);
 686                               Output_Range (T.From, T.To);
 687                            end if;
 688
 689                            exit when T.Last;
 690                            Start := Start + 1;
 691                         end;
 692                      end loop;
 693
 694                   when others =>
 695                      raise Program_Error;
 696                end case;
 697
 698                Write_Info_Terminate;
 699             end;
 700
 701             exit when Start = Stop;
 702             Start := Start + 1;
 703
 704             pragma Assert (Start <= Stop);
 705          end loop;
 706       end loop;
 707    end SCO_Output;
 708
 709    ----------------
 710    -- SCO_Record --
 711    ----------------
 712
 713    procedure SCO_Record (U : Unit_Number_Type) is
 714       Lu   : Node_Id;
 715       From : Nat;
 716
 717    begin
 718       --  Ignore call if not generating code and generating SCO's
 719
 720       if not (Generate_SCO and then Operating_Mode = Generate_Code) then
 721          return;
 722       end if;
 723
 724       --  Ignore call if this unit already recorded
 725
 726       for J in 1 .. SCO_Unit_Table.Last loop
 727          if SCO_Unit_Table.Table (J).Unit = U then
 728             return;
 729          end if;
 730       end loop;
 731
 732       --  Otherwise record starting entry
 733
 734       From := SCO_Table.Last + 1;
 735
 736       --  Get Unit (checking case of subunit)
 737
 738       Lu := Unit (Cunit (U));
 739
 740       if Nkind (Lu) = N_Subunit then
 741          Lu := Proper_Body (Lu);
 742       end if;
 743
 744       --  Traverse the unit
 745
 746       if Nkind (Lu) = N_Subprogram_Body then
 747          Traverse_Subprogram_Body (Lu);
 748
 749       elsif Nkind (Lu) = N_Package_Declaration then
 750          Traverse_Package_Declaration (Lu);
 751
 752       elsif Nkind (Lu) = N_Package_Body then
 753          Traverse_Package_Body (Lu);
 754
 755       elsif Nkind (Lu) = N_Generic_Package_Declaration then
 756          Traverse_Generic_Package_Declaration (Lu);
 757
 758       --  For anything else, the only issue is default expressions for
 759       --  parameters, where we have to worry about possible embedded decisions
 760       --  but nothing else.
 761
 762       else
 763          Process_Decisions (Lu, 'X');
 764       end if;
 765
 766       --  Make entry for new unit in unit table
 767
 768       SCO_Unit_Table.Append ((Unit => U, From => From, To => SCO_Table.Last));
 769    end SCO_Record;
 770
 771    -----------------------
 772    -- Set_SCO_Condition --
 773    -----------------------
 774
 775    procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is
 776       Index : constant Nat := Condition_Hash_Table.Get (First_Loc);
 777    begin
 778       if Index /= 0 then
 779          SCO_Table.Table (Index).C2 := Typ;
 780       end if;
 781    end Set_SCO_Condition;
 782
 783    ---------------------
 784    -- Set_Table_Entry --
 785    ---------------------
 786
 787    procedure Set_Table_Entry
 788      (C1   : Character;
 789       C2   : Character;
 790       From : Source_Ptr;
 791       To   : Source_Ptr;
 792       Last : Boolean)
 793    is
 794    begin
 795       SCO_Table.Append ((C1   => C1,
 796                          C2   => C2,
 797                          From => From,
 798                          To   => To,
 799                          Last => Last));
 800    end Set_Table_Entry;
 801
 802    -----------------------------------------
 803    -- Traverse_Declarations_Or_Statements --
 804    -----------------------------------------
 805
 806    procedure Traverse_Declarations_Or_Statements (L : List_Id) is
 807       N     : Node_Id;
 808       Start : Source_Ptr;
 809       Dummy : Source_Ptr;
 810       Stop  : Source_Ptr;
 811       From  : Source_Ptr;
 812       To    : Source_Ptr;
 813
 814       Term  : Boolean;
 815       --  Set False if current entity terminates statement list
 816
 817       procedure Set_Statement_Entry;
 818       --  If Start is No_Location, does nothing, otherwise outputs a SCO_Table
 819       --  statement entry for the range Start-Stop and then sets both Start
 820       --  and Stop to No_Location. Unconditionally sets Term to True. This is
 821       --  called when we find a statement or declaration that generates its
 822       --  own table entry, so that we must end the current statement sequence.
 823
 824       -------------------------
 825       -- Set_Statement_Entry --
 826       -------------------------
 827
 828       procedure Set_Statement_Entry is
 829       begin
 830          Term := True;
 831
 832          if Start /= No_Location then
 833             Set_Table_Entry ('S', ' ', Start, Stop, False);
 834             Start := No_Location;
 835             Stop  := No_Location;
 836          end if;
 837       end Set_Statement_Entry;
 838
 839    --  Start of processing for Traverse_Declarations_Or_Statements
 840
 841    begin
 842       if Is_Non_Empty_List (L) then
 843          N := First (L);
 844          Start := No_Location;
 845
 846          --  Loop through statements or declarations
 847
 848          while Present (N) loop
 849             Term := False;
 850
 851             case Nkind (N) is
 852
 853                --  Package declaration
 854
 855                when N_Package_Declaration =>
 856                   Set_Statement_Entry;
 857                   Traverse_Package_Declaration (N);
 858
 859                --  Generic package declaration
 860
 861                when N_Generic_Package_Declaration =>
 862                   Set_Statement_Entry;
 863                   Traverse_Generic_Package_Declaration (N);
 864
 865                --  Package body
 866
 867                when N_Package_Body =>
 868                   Set_Statement_Entry;
 869                   Traverse_Package_Body (N);
 870
 871                --  Subprogram declaration
 872
 873                when N_Subprogram_Declaration =>
 874                   Set_Statement_Entry;
 875                   Process_Decisions
 876                     (Parameter_Specifications (Specification (N)), 'X');
 877
 878                --  Generic subprogram declaration
 879
 880                when N_Generic_Subprogram_Declaration =>
 881                   Set_Statement_Entry;
 882                   Process_Decisions (Generic_Formal_Declarations (N), 'X');
 883                   Process_Decisions
 884                     (Parameter_Specifications (Specification (N)), 'X');
 885
 886                --  Subprogram_Body
 887
 888                when N_Subprogram_Body =>
 889                   Set_Statement_Entry;
 890                   Traverse_Subprogram_Body (N);
 891
 892                --  Exit statement
 893
 894                when N_Exit_Statement =>
 895                   Set_Statement_Entry;
 896                   Process_Decisions (Condition (N), 'E');
 897
 898                   --  This is an exit point
 899
 900                   Sloc_Range (N, From, To);
 901                   Set_Table_Entry ('T', ' ', From, To, False);
 902
 903                --  Label (breaks statement sequence)
 904
 905                when N_Label =>
 906                   Set_Statement_Entry;
 907
 908                --  Block statement
 909
 910                when N_Block_Statement =>
 911                   Set_Statement_Entry;
 912                   Traverse_Declarations_Or_Statements (Declarations (N));
 913                   Traverse_Handled_Statement_Sequence
 914                     (Handled_Statement_Sequence (N));
 915
 916                --  If statement
 917
 918                when N_If_Statement =>
 919                   Set_Statement_Entry;
 920                   Process_Decisions (Condition (N), 'I');
 921                   Traverse_Declarations_Or_Statements (Then_Statements (N));
 922
 923                   if Present (Elsif_Parts (N)) then
 924                      declare
 925                         Elif : Node_Id := First (Elsif_Parts (N));
 926                      begin
 927                         while Present (Elif) loop
 928                            Process_Decisions (Condition (Elif), 'I');
 929                            Traverse_Declarations_Or_Statements
 930                              (Then_Statements (Elif));
 931                            Next (Elif);
 932                         end loop;
 933                      end;
 934                   end if;
 935
 936                   Traverse_Declarations_Or_Statements (Else_Statements (N));
 937
 938                   --  Unconditional exit points
 939
 940                when N_Requeue_Statement |
 941                     N_Goto_Statement    |
 942                     N_Raise_Statement   =>
 943                   Set_Statement_Entry;
 944                   Sloc_Range (N, From, To);
 945                   Set_Table_Entry ('T', ' ', From, To, False);
 946
 947                --  Simple return statement
 948
 949                when N_Simple_Return_Statement =>
 950                   Set_Statement_Entry;
 951
 952                   --  Process possible return expression
 953
 954                   Process_Decisions (Expression (N), 'X');
 955
 956                   --  Return is an exit point
 957
 958                   Sloc_Range (N, From, To);
 959                   Set_Table_Entry ('T', ' ', From, To, False);
 960
 961                --  Extended return statement
 962
 963                when N_Extended_Return_Statement =>
 964                   Set_Statement_Entry;
 965                   Traverse_Declarations_Or_Statements
 966                     (Return_Object_Declarations (N));
 967                   Traverse_Handled_Statement_Sequence
 968                     (Handled_Statement_Sequence (N));
 969
 970                   --  Return is an exit point
 971
 972                   Sloc_Range (N, From, To);
 973                   Set_Table_Entry ('T', ' ', From, To, False);
 974
 975                --  Loop
 976
 977                when N_Loop_Statement =>
 978
 979                   --  Even if not a while loop, we want a new statement seq
 980
 981                   Set_Statement_Entry;
 982
 983                   if Present (Iteration_Scheme (N)) then
 984                      Process_Decisions
 985                        (Condition (Iteration_Scheme (N)), 'W');
 986                   end if;
 987
 988                   Traverse_Declarations_Or_Statements (Statements (N));
 989
 990                --  All other cases
 991
 992                when others =>
 993                   if Has_Decision (N) then
 994                      Set_Statement_Entry;
 995                      Process_Decisions (N, 'X');
 996                   end if;
 997             end case;
 998
 999             --  If that element did not terminate the current sequence of
1000             --  statements, then establish or extend this sequence.
1001
1002             if not Term then
1003                if Start = No_Location then
1004                   Sloc_Range (N, Start, Stop);
1005                else
1006                   Sloc_Range (N, Dummy, Stop);
1007                end if;
1008             end if;
1009
1010             Next (N);
1011          end loop;
1012
1013          Set_Statement_Entry;
1014       end if;
1015    end Traverse_Declarations_Or_Statements;
1016
1017    ------------------------------------------
1018    -- Traverse_Generic_Package_Declaration --
1019    ------------------------------------------
1020
1021    procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
1022    begin
1023       Process_Decisions (Generic_Formal_Declarations (N), 'X');
1024       Traverse_Package_Declaration (N);
1025    end Traverse_Generic_Package_Declaration;
1026
1027    -----------------------------------------
1028    -- Traverse_Handled_Statement_Sequence --
1029    -----------------------------------------
1030
1031    procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
1032       Handler : Node_Id;
1033
1034    begin
1035       if Present (N) then
1036          Traverse_Declarations_Or_Statements (Statements (N));
1037
1038          if Present (Exception_Handlers (N)) then
1039             Handler := First (Exception_Handlers (N));
1040             while Present (Handler) loop
1041                Traverse_Declarations_Or_Statements (Statements (Handler));
1042                Next (Handler);
1043             end loop;
1044          end if;
1045       end if;
1046    end Traverse_Handled_Statement_Sequence;
1047
1048    ---------------------------
1049    -- Traverse_Package_Body --
1050    ---------------------------
1051
1052    procedure Traverse_Package_Body (N : Node_Id) is
1053    begin
1054       Traverse_Declarations_Or_Statements (Declarations (N));
1055       Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1056    end Traverse_Package_Body;
1057
1058    ----------------------------------
1059    -- Traverse_Package_Declaration --
1060    ----------------------------------
1061
1062    procedure Traverse_Package_Declaration (N : Node_Id) is
1063       Spec : constant Node_Id := Specification (N);
1064    begin
1065       Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
1066       Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
1067    end Traverse_Package_Declaration;
1068
1069    ------------------------------
1070    -- Traverse_Subprogram_Body --
1071    ------------------------------
1072
1073    procedure Traverse_Subprogram_Body (N : Node_Id) is
1074    begin
1075       Traverse_Declarations_Or_Statements (Declarations (N));
1076       Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1077    end Traverse_Subprogram_Body;
1078
1079 end Par_SCO;