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