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