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 Snames;   use Snames;
  39 with Table;
  40
  41 with GNAT.HTable;      use GNAT.HTable;
  42 with GNAT.Heap_Sort_G;
  43
  44 package body Par_SCO is
  45
  46    -----------------------
  47    -- Unit Number Table --
  48    -----------------------
  49
  50    --  This table parallels the SCO_Unit_Table, keeping track of the unit
  51    --  numbers corresponding to the entries made in this table, so that before
  52    --  writing out the SCO information to the ALI file, we can fill in the
  53    --  proper dependency numbers and file names.
  54
  55    --  Note that the zero'th entry is here for convenience in sorting the
  56    --  table, the real lower bound is 1.
  57
  58    package SCO_Unit_Number_Table is new Table.Table (
  59      Table_Component_Type => Unit_Number_Type,
  60      Table_Index_Type     => SCO_Unit_Index,
  61      Table_Low_Bound      => 0, -- see note above on sort
  62      Table_Initial        => 20,
  63      Table_Increment      => 200,
  64      Table_Name           => "SCO_Unit_Number_Entry");
  65
  66    --------------------------
  67    -- Condition Hash Table --
  68    --------------------------
  69
  70    --  We need to be able to get to conditions quickly for handling the calls
  71    --  to Set_SCO_Condition efficiently. For this purpose we identify the
  72    --  conditions in the table by their starting sloc, and use the following
  73    --  hash table to map from these starting sloc values to SCO_Table indexes.
  74
  75    type Header_Num is new Integer range 0 .. 996;
  76    --  Type for hash table headers
  77
  78    function Hash (F : Source_Ptr) return Header_Num;
  79    --  Function to Hash source pointer value
  80
  81    function Equal (F1, F2 : Source_Ptr) return Boolean;
  82    --  Function to test two keys for equality
  83
  84    package Condition_Hash_Table is new Simple_HTable
  85      (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
  86    --  The actual hash table
  87
  88    --------------------------
  89    -- Internal Subprograms --
  90    --------------------------
  91
  92    function Has_Decision (N : Node_Id) return Boolean;
  93    --  N is the node for a subexpression. Returns True if the subexpression
  94    --  contains a nested decision (i.e. either is a logical operator, or
  95    --  contains a logical operator in its subtree).
  96
  97    function Is_Logical_Operator (N : Node_Id) return Boolean;
  98    --  N is the node for a subexpression. This procedure just tests N to see
  99    --  if it is a logical operator (including short circuit conditions, but
 100    --  excluding OR and AND) and returns True if so, False otherwise, it does
 101    --  no other processing.
 102
 103    procedure Process_Decisions (N : Node_Id; T : Character);
 104    --  If N is Empty, has no effect. Otherwise scans the tree for the node N,
 105    --  to output any decisions it contains. T is one of IEPWX (for context of
 106    --  expresion: if/exit when/pragma/while/expression). If T is other than X,
 107    --  then a decision is always present (at the very least a simple decision
 108    --  is present at the top level).
 109
 110    procedure Process_Decisions (L : List_Id; T : Character);
 111    --  Calls above procedure for each element of the list L
 112
 113    procedure Set_Table_Entry
 114      (C1   : Character;
 115       C2   : Character;
 116       From : Source_Ptr;
 117       To   : Source_Ptr;
 118       Last : Boolean);
 119    --  Append an entry to SCO_Table with fields set as per arguments
 120
 121    procedure Traverse_Declarations_Or_Statements  (L : List_Id);
 122    procedure Traverse_Generic_Package_Declaration (N : Node_Id);
 123    procedure Traverse_Handled_Statement_Sequence  (N : Node_Id);
 124    procedure Traverse_Package_Body                (N : Node_Id);
 125    procedure Traverse_Package_Declaration         (N : Node_Id);
 126    procedure Traverse_Subprogram_Body             (N : Node_Id);
 127    --  Traverse the corresponding construct, generating SCO table entries
 128
 129    procedure Write_SCOs_To_ALI_File is new Put_SCOs;
 130    --  Write SCO information to the ALI file using routines in Lib.Util
 131
 132    ----------
 133    -- dsco --
 134    ----------
 135
 136    procedure dsco is
 137    begin
 138       --  Dump SCO unit table
 139
 140       Write_Line ("SCO Unit Table");
 141       Write_Line ("--------------");
 142
 143       for Index in 1 .. SCO_Unit_Table.Last loop
 144          declare
 145             UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
 146
 147          begin
 148             Write_Str ("  ");
 149             Write_Int (Int (Index));
 150             Write_Str (".  Dep_Num = ");
 151             Write_Int (Int (UTE.Dep_Num));
 152             Write_Str ("  From = ");
 153             Write_Int (Int (UTE.From));
 154             Write_Str ("  To = ");
 155             Write_Int (Int (UTE.To));
 156
 157             Write_Str ("  File_Name = """);
 158
 159             if UTE.File_Name /= null then
 160                Write_Str (UTE.File_Name.all);
 161             end if;
 162
 163             Write_Char ('"');
 164             Write_Eol;
 165          end;
 166       end loop;
 167
 168       --  Dump SCO Unit number table if it contains any entries
 169
 170       if SCO_Unit_Number_Table.Last >= 1 then
 171          Write_Eol;
 172          Write_Line ("SCO Unit Number Table");
 173          Write_Line ("---------------------");
 174
 175          for Index in 1 .. SCO_Unit_Number_Table.Last loop
 176             Write_Str ("  ");
 177             Write_Int (Int (Index));
 178             Write_Str (". Unit_Number = ");
 179             Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
 180             Write_Eol;
 181          end loop;
 182       end if;
 183
 184       --  Dump SCO table itself
 185
 186       Write_Eol;
 187       Write_Line ("SCO Table");
 188       Write_Line ("---------");
 189
 190       for Index in 1 .. SCO_Table.Last loop
 191          declare
 192             T : SCO_Table_Entry renames SCO_Table.Table (Index);
 193
 194          begin
 195             Write_Str  ("  ");
 196             Write_Int  (Index);
 197             Write_Char ('.');
 198
 199             if T.C1 /= ' ' then
 200                Write_Str  ("  C1 = '");
 201                Write_Char (T.C1);
 202                Write_Char (''');
 203             end if;
 204
 205             if T.C2 /= ' ' then
 206                Write_Str  ("  C2 = '");
 207                Write_Char (T.C2);
 208                Write_Char (''');
 209             end if;
 210
 211             if T.From /= No_Source_Location then
 212                Write_Str ("  From = ");
 213                Write_Int (Int (T.From.Line));
 214                Write_Char (':');
 215                Write_Int (Int (T.From.Col));
 216             end if;
 217
 218             if T.To /= No_Source_Location then
 219                Write_Str ("  To = ");
 220                Write_Int (Int (T.To.Line));
 221                Write_Char (':');
 222                Write_Int (Int (T.To.Col));
 223             end if;
 224
 225             if T.Last then
 226                Write_Str ("  True");
 227             else
 228                Write_Str ("  False");
 229             end if;
 230
 231             Write_Eol;
 232          end;
 233       end loop;
 234    end dsco;
 235
 236    -----------
 237    -- Equal --
 238    -----------
 239
 240    function Equal (F1, F2 : Source_Ptr) return Boolean is
 241    begin
 242       return F1 = F2;
 243    end Equal;
 244
 245    ------------------
 246    -- Has_Decision --
 247    ------------------
 248
 249    function Has_Decision (N : Node_Id) return Boolean is
 250
 251       function Check_Node (N : Node_Id) return Traverse_Result;
 252
 253       ----------------
 254       -- Check_Node --
 255       ----------------
 256
 257       function Check_Node (N : Node_Id) return Traverse_Result is
 258       begin
 259          if Is_Logical_Operator (N) then
 260             return Abandon;
 261          else
 262             return OK;
 263          end if;
 264       end Check_Node;
 265
 266       function Traverse is new Traverse_Func (Check_Node);
 267
 268    --  Start of processing for Has_Decision
 269
 270    begin
 271       return Traverse (N) = Abandon;
 272    end Has_Decision;
 273
 274    ----------
 275    -- Hash --
 276    ----------
 277
 278    function Hash (F : Source_Ptr) return Header_Num is
 279    begin
 280       return Header_Num (Nat (F) mod 997);
 281    end Hash;
 282
 283    ----------------
 284    -- Initialize --
 285    ----------------
 286
 287    procedure Initialize is
 288    begin
 289       SCO_Unit_Number_Table.Init;
 290
 291       --  Set dummy 0'th entry in place for sort
 292
 293       SCO_Unit_Number_Table.Increment_Last;
 294    end Initialize;
 295
 296    -------------------------
 297    -- Is_Logical_Operator --
 298    -------------------------
 299
 300    function Is_Logical_Operator (N : Node_Id) return Boolean is
 301    begin
 302       return Nkind_In (N, 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, output table entries and then process
 440                --  operands recursively to deal with nested conditions.
 441
 442             when N_And_Then                    |
 443                  N_Or_Else                     |
 444                  N_Op_Not                      =>
 445
 446                declare
 447                   T : Character;
 448
 449                begin
 450                   --  If outer level, then type comes from call, otherwise it
 451                   --  is more deeply nested and counts as X for expression.
 452
 453                   if N = Process_Decisions.N then
 454                      T := Process_Decisions.T;
 455                   else
 456                      T := 'X';
 457                   end if;
 458
 459                   --  Output header for sequence
 460
 461                   Set_Table_Entry (T, ' ', No_Location, No_Location, False);
 462
 463                   --  Output the decision
 464
 465                   Output_Decision_Operand (N);
 466
 467                   --  Change Last in last table entry to True to mark end
 468
 469                   SCO_Table.Table (SCO_Table.Last).Last := True;
 470
 471                   --  Process any embedded decisions
 472
 473                   Process_Decision_Operand (N);
 474                   return Skip;
 475                end;
 476
 477             --  Conditional expression, processed like an if statement
 478
 479             when N_Conditional_Expression      =>
 480                declare
 481                   Cond : constant Node_Id := First (Expressions (N));
 482                   Thnx : constant Node_Id := Next (Cond);
 483                   Elsx : constant Node_Id := Next (Thnx);
 484                begin
 485                   Process_Decisions (Cond, 'I');
 486                   Process_Decisions (Thnx, 'X');
 487                   Process_Decisions (Elsx, 'X');
 488                   return Skip;
 489                end;
 490
 491             --  All other cases, continue scan
 492
 493             when others =>
 494                return OK;
 495
 496          end case;
 497       end Process_Node;
 498
 499       procedure Traverse is new Traverse_Proc (Process_Node);
 500
 501    --  Start of processing for Process_Decisions
 502
 503    begin
 504       if No (N) then
 505          return;
 506       end if;
 507
 508       --  See if we have simple decision at outer level and if so then
 509       --  generate the decision entry for this simple decision. A simple
 510       --  decision is a boolean expression (which is not a logical operator
 511       --  or short circuit form) appearing as the operand of an IF, WHILE
 512       --  or EXIT WHEN construct.
 513
 514       if T /= 'X' and then not Is_Logical_Operator (N) then
 515          Output_Element (N, T);
 516
 517          --  Change Last in last table entry to True to mark end of
 518          --  sequence, which is this case is only one element long.
 519
 520          SCO_Table.Table (SCO_Table.Last).Last := True;
 521       end if;
 522
 523       Traverse (N);
 524    end Process_Decisions;
 525
 526    -----------
 527    -- pscos --
 528    -----------
 529
 530    procedure pscos is
 531
 532       procedure Write_Info_Char (C : Character) renames Write_Char;
 533       --  Write one character;
 534
 535       procedure Write_Info_Initiate (Key : Character) renames Write_Char;
 536       --  Start new one and write one character;
 537
 538       procedure Write_Info_Nat (N : Nat);
 539       --  Write value of N
 540
 541       procedure Write_Info_Terminate renames Write_Eol;
 542       --  Terminate current line
 543
 544       --------------------
 545       -- Write_Info_Nat --
 546       --------------------
 547
 548       procedure Write_Info_Nat (N : Nat) is
 549       begin
 550          Write_Int (N);
 551       end Write_Info_Nat;
 552
 553       procedure Debug_Put_SCOs is new Put_SCOs;
 554
 555       --  Start of processing for pscos
 556
 557    begin
 558       Debug_Put_SCOs;
 559    end pscos;
 560
 561    ----------------
 562    -- SCO_Output --
 563    ----------------
 564
 565    procedure SCO_Output is
 566    begin
 567       if Debug_Flag_Dot_OO then
 568          dsco;
 569       end if;
 570
 571       --  Sort the unit tables based on dependency numbers
 572
 573       Unit_Table_Sort : declare
 574
 575          function Lt (Op1, Op2 : Natural) return Boolean;
 576          --  Comparison routine for sort call
 577
 578          procedure Move (From : Natural; To : Natural);
 579          --  Move routine for sort call
 580
 581          --------
 582          -- Lt --
 583          --------
 584
 585          function Lt (Op1, Op2 : Natural) return Boolean is
 586          begin
 587             return
 588               Dependency_Num
 589                 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
 590                      <
 591               Dependency_Num
 592                 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
 593          end Lt;
 594
 595          ----------
 596          -- Move --
 597          ----------
 598
 599          procedure Move (From : Natural; To : Natural) is
 600          begin
 601             SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
 602               SCO_Unit_Table.Table (SCO_Unit_Index (From));
 603             SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
 604               SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
 605          end Move;
 606
 607          package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
 608
 609       --  Start of processing for Unit_Table_Sort
 610
 611       begin
 612          Sorting.Sort (Integer (SCO_Unit_Table.Last));
 613       end Unit_Table_Sort;
 614
 615       --  Loop through entries in the unit table to set file name and
 616       --  dependency number entries.
 617
 618       for J in 1 .. SCO_Unit_Table.Last loop
 619          declare
 620             U   : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
 621             UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
 622          begin
 623             Get_Name_String (Reference_Name (Source_Index (U)));
 624             UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
 625             UTE.Dep_Num := Dependency_Num (U);
 626          end;
 627       end loop;
 628
 629       --  Now the tables are all setup for output to the ALI file
 630
 631       Write_SCOs_To_ALI_File;
 632    end SCO_Output;
 633
 634    ----------------
 635    -- SCO_Record --
 636    ----------------
 637
 638    procedure SCO_Record (U : Unit_Number_Type) is
 639       Lu   : Node_Id;
 640       From : Nat;
 641
 642    begin
 643       --  Ignore call if not generating code and generating SCO's
 644
 645       if not (Generate_SCO and then Operating_Mode = Generate_Code) then
 646          return;
 647       end if;
 648
 649       --  Ignore call if this unit already recorded
 650
 651       for J in 1 .. SCO_Unit_Number_Table.Last loop
 652          if U = SCO_Unit_Number_Table.Table (J) then
 653             return;
 654          end if;
 655       end loop;
 656
 657       --  Otherwise record starting entry
 658
 659       From := SCO_Table.Last + 1;
 660
 661       --  Get Unit (checking case of subunit)
 662
 663       Lu := Unit (Cunit (U));
 664
 665       if Nkind (Lu) = N_Subunit then
 666          Lu := Proper_Body (Lu);
 667       end if;
 668
 669       --  Traverse the unit
 670
 671       if Nkind (Lu) = N_Subprogram_Body then
 672          Traverse_Subprogram_Body (Lu);
 673
 674       elsif Nkind (Lu) = N_Package_Declaration then
 675          Traverse_Package_Declaration (Lu);
 676
 677       elsif Nkind (Lu) = N_Package_Body then
 678          Traverse_Package_Body (Lu);
 679
 680       elsif Nkind (Lu) = N_Generic_Package_Declaration then
 681          Traverse_Generic_Package_Declaration (Lu);
 682
 683       --  For anything else, the only issue is default expressions for
 684       --  parameters, where we have to worry about possible embedded decisions
 685       --  but nothing else.
 686
 687       else
 688          Process_Decisions (Lu, 'X');
 689       end if;
 690
 691       --  Make entry for new unit in unit tables, we will fill in the file
 692       --  name and dependency numbers later.
 693
 694       SCO_Unit_Table.Append (
 695         (Dep_Num   => 0,
 696          File_Name => null,
 697          From      => From,
 698          To        => SCO_Table.Last));
 699
 700       SCO_Unit_Number_Table.Append (U);
 701    end SCO_Record;
 702
 703    -----------------------
 704    -- Set_SCO_Condition --
 705    -----------------------
 706
 707    procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is
 708       Index : constant Nat := Condition_Hash_Table.Get (First_Loc);
 709    begin
 710       if Index /= 0 then
 711          SCO_Table.Table (Index).C2 := Typ;
 712       end if;
 713    end Set_SCO_Condition;
 714
 715    ---------------------
 716    -- Set_Table_Entry --
 717    ---------------------
 718
 719    procedure Set_Table_Entry
 720      (C1   : Character;
 721       C2   : Character;
 722       From : Source_Ptr;
 723       To   : Source_Ptr;
 724       Last : Boolean)
 725    is
 726       function To_Source_Location (S : Source_Ptr) return Source_Location;
 727       --  Converts Source_Ptr value to Source_Location (line/col) format
 728
 729       ------------------------
 730       -- To_Source_Location --
 731       ------------------------
 732
 733       function To_Source_Location (S : Source_Ptr) return Source_Location is
 734       begin
 735          if S = No_Location then
 736             return No_Source_Location;
 737          else
 738             return
 739               (Line => Get_Logical_Line_Number (S),
 740                Col  => Get_Column_Number (S));
 741          end if;
 742       end To_Source_Location;
 743
 744    --  Start of processing for Set_Table_Entry
 745
 746    begin
 747       Add_SCO
 748         (C1   => C1,
 749          C2   => C2,
 750          From => To_Source_Location (From),
 751          To   => To_Source_Location (To),
 752          Last => Last);
 753    end Set_Table_Entry;
 754
 755    -----------------------------------------
 756    -- Traverse_Declarations_Or_Statements --
 757    -----------------------------------------
 758
 759    procedure Traverse_Declarations_Or_Statements (L : List_Id) is
 760       N     : Node_Id;
 761       Dummy : Source_Ptr;
 762
 763       type SC_Entry is record
 764          From : Source_Ptr;
 765          To   : Source_Ptr;
 766          Typ  : Character;
 767       end record;
 768       --  Used to store a single entry in the following array
 769
 770       SC_Array : array (Nat range 1 .. 10_000) of SC_Entry;
 771       SC_Last  : Nat;
 772       --  Used to store statement components for a CS entry to be output
 773       --  as a result of the call to this procedure. SC_Last is the last
 774       --  entry stored, so the current statement sequence is represented
 775       --  by SC_Array (1 .. SC_Last). Extend_Statement_Sequence adds an
 776       --  entry to this array, and Set_Statement_Entry clears it, copying
 777       --  the entries to the main SCO output table. The reason that we do
 778       --  the temporary caching of results in this array is that we want
 779       --  the SCO table entries for a given CS line to be contiguous, and
 780       --  the processing may output intermediate entries such as decision
 781       --  entries. Note that the limit of 10_000 here is arbitrary, but does
 782       --  not cause any trouble, if we encounter more than 10_000 statements
 783       --  we simply break the current CS sequence at that point, which is
 784       --  harmless, since this is only used for back annotation and it is
 785       --  not critical that back annotation always work in all cases. Anyway
 786       --  exceeding 10,000 statements in a basic block is very unlikely.
 787
 788       procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
 789       --  Extend the current statement sequence to encompass the node N. Typ
 790       --  is the letter that identifies the type of statement/declaration that
 791       --  is being added to the sequence.
 792
 793       procedure Extend_Statement_Sequence
 794         (From : Node_Id;
 795          To   : Node_Id;
 796          Typ  : Character);
 797       --  This version extends the current statement sequence with an entry
 798       --  that starts with the first token of From, and ends with the last
 799       --  token of To. It is used for example in a CASE statement to cover
 800       --  the range from the CASE token to the last token of the expression.
 801
 802       procedure Set_Statement_Entry;
 803       --  If Start is No_Location, does nothing, otherwise outputs a SCO_Table
 804       --  statement entry for the range Start-Stop and then sets both Start
 805       --  and Stop to No_Location. Unconditionally sets Term to True. This is
 806       --  called when we find a statement or declaration that generates its
 807       --  own table entry, so that we must end the current statement sequence.
 808
 809       -------------------------
 810       -- Set_Statement_Entry --
 811       -------------------------
 812
 813       procedure Set_Statement_Entry is
 814          C1   : Character;
 815
 816       begin
 817          if SC_Last /= 0 then
 818             for J in 1 .. SC_Last loop
 819                if J = 1 then
 820                   C1 := 'S';
 821                else
 822                   C1 := 's';
 823                end if;
 824
 825                Set_Table_Entry
 826                  (C1   => C1,
 827                   C2   => SC_Array (J).Typ,
 828                   From => SC_Array (J).From,
 829                   To   => SC_Array (J).To,
 830                   Last => (J = SC_Last));
 831             end loop;
 832
 833             SC_Last := 0;
 834          end if;
 835       end Set_Statement_Entry;
 836
 837       -------------------------------
 838       -- Extend_Statement_Sequence --
 839       -------------------------------
 840
 841       procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
 842       begin
 843          --  Clear out statement sequence if array full
 844
 845          if SC_Last = SC_Array'Last then
 846             Set_Statement_Entry;
 847          else
 848             SC_Last := SC_Last + 1;
 849          end if;
 850
 851          --  Record new entry
 852
 853          Sloc_Range
 854            (N, SC_Array (SC_Last).From, SC_Array (SC_Last).To);
 855          SC_Array (SC_Last).Typ := Typ;
 856       end Extend_Statement_Sequence;
 857
 858       procedure Extend_Statement_Sequence
 859         (From : Node_Id;
 860          To   : Node_Id;
 861          Typ  : Character)
 862       is
 863       begin
 864          --  Clear out statement sequence if array full
 865
 866          if SC_Last = SC_Array'Last then
 867             Set_Statement_Entry;
 868          else
 869             SC_Last := SC_Last + 1;
 870          end if;
 871
 872          --  Make new entry
 873
 874          Sloc_Range (From, SC_Array (SC_Last).From, Dummy);
 875          Sloc_Range (To, Dummy, SC_Array (SC_Last).To);
 876          SC_Array (SC_Last).Typ := Typ;
 877       end Extend_Statement_Sequence;
 878
 879    --  Start of processing for Traverse_Declarations_Or_Statements
 880
 881    begin
 882       if Is_Non_Empty_List (L) then
 883          SC_Last := 0;
 884
 885          --  Loop through statements or declarations
 886
 887          N := First (L);
 888          while Present (N) loop
 889
 890             --  Initialize or extend current statement sequence. Note that for
 891             --  special cases such as IF and Case statements we will modify
 892             --  the range to exclude internal statements that should not be
 893             --  counted as part of the current statement sequence.
 894
 895             case Nkind (N) is
 896
 897                --  Package declaration
 898
 899                when N_Package_Declaration =>
 900                   Set_Statement_Entry;
 901                   Traverse_Package_Declaration (N);
 902
 903                --  Generic package declaration
 904
 905                when N_Generic_Package_Declaration =>
 906                   Set_Statement_Entry;
 907                   Traverse_Generic_Package_Declaration (N);
 908
 909                --  Package body
 910
 911                when N_Package_Body =>
 912                   Set_Statement_Entry;
 913                   Traverse_Package_Body (N);
 914
 915                --  Subprogram declaration
 916
 917                when N_Subprogram_Declaration =>
 918                   Set_Statement_Entry;
 919                   Process_Decisions
 920                     (Parameter_Specifications (Specification (N)), 'X');
 921
 922                --  Generic subprogram declaration
 923
 924                when N_Generic_Subprogram_Declaration =>
 925                   Set_Statement_Entry;
 926                   Process_Decisions (Generic_Formal_Declarations (N), 'X');
 927                   Process_Decisions
 928                     (Parameter_Specifications (Specification (N)), 'X');
 929
 930                --  Subprogram_Body
 931
 932                when N_Subprogram_Body =>
 933                   Set_Statement_Entry;
 934                   Traverse_Subprogram_Body (N);
 935
 936                --  Exit statement, which is an exit statement in the SCO sense,
 937                --  so it is included in the current statement sequence, but
 938                --  then it terminates this sequence. We also have to process
 939                --  any decisions in the exit statement expression.
 940
 941                when N_Exit_Statement =>
 942                   Extend_Statement_Sequence (N, ' ');
 943                   Set_Statement_Entry;
 944                   Process_Decisions (Condition (N), 'E');
 945
 946                --  Label, which breaks the current statement sequence, but the
 947                --  label itself is not included in the next statement sequence,
 948                --  since it generates no code.
 949
 950                when N_Label =>
 951                   Set_Statement_Entry;
 952
 953                --  Block statement, which breaks the current statement sequence
 954
 955                when N_Block_Statement =>
 956                   Set_Statement_Entry;
 957                   Traverse_Declarations_Or_Statements (Declarations (N));
 958                   Traverse_Handled_Statement_Sequence
 959                     (Handled_Statement_Sequence (N));
 960
 961                --  If statement, which breaks the current statement sequence,
 962                --  but we include the condition in the current sequence.
 963
 964                when N_If_Statement =>
 965                   Extend_Statement_Sequence (N, Condition (N), 'I');
 966                   Set_Statement_Entry;
 967                   Process_Decisions (Condition (N), 'I');
 968                   Traverse_Declarations_Or_Statements (Then_Statements (N));
 969
 970                   if Present (Elsif_Parts (N)) then
 971                      declare
 972                         Elif : Node_Id := First (Elsif_Parts (N));
 973                      begin
 974                         while Present (Elif) loop
 975                            Process_Decisions (Condition (Elif), 'I');
 976                            Traverse_Declarations_Or_Statements
 977                              (Then_Statements (Elif));
 978                            Next (Elif);
 979                         end loop;
 980                      end;
 981                   end if;
 982
 983                   Traverse_Declarations_Or_Statements (Else_Statements (N));
 984
 985                --  Case statement, which breaks the current statement sequence,
 986                --  but we include the expression in the current sequence.
 987
 988                when N_Case_Statement =>
 989                   Extend_Statement_Sequence (N, Expression (N), 'C');
 990                   Set_Statement_Entry;
 991                   Process_Decisions (Expression (N), 'X');
 992
 993                   --  Process case branches
 994
 995                   declare
 996                      Alt : Node_Id;
 997
 998                   begin
 999                      Alt := First (Alternatives (N));
1000                      while Present (Alt) loop
1001                         Traverse_Declarations_Or_Statements (Statements (Alt));
1002                         Next (Alt);
1003                      end loop;
1004                   end;
1005
1006                --  Unconditional exit points, which are included in the current
1007                --  statement sequence, but then terminate it
1008
1009                when N_Requeue_Statement |
1010                     N_Goto_Statement    |
1011                     N_Raise_Statement   =>
1012                   Extend_Statement_Sequence (N, ' ');
1013                   Set_Statement_Entry;
1014
1015                --  Simple return statement. which is an exit point, but we
1016                --  have to process the return expression for decisions.
1017
1018                when N_Simple_Return_Statement =>
1019                   Extend_Statement_Sequence (N, ' ');
1020                   Set_Statement_Entry;
1021                   Process_Decisions (Expression (N), 'X');
1022
1023                --  Extended return statement
1024
1025                when N_Extended_Return_Statement =>
1026                   declare
1027                      Odecl : constant Node_Id :=
1028                                First (Return_Object_Declarations (N));
1029                   begin
1030                      if Present (Expression (Odecl)) then
1031                         Extend_Statement_Sequence
1032                           (N, Expression (Odecl), 'R');
1033                         Process_Decisions (Expression (Odecl), 'X');
1034                      end if;
1035                   end;
1036
1037                   Traverse_Handled_Statement_Sequence
1038                     (Handled_Statement_Sequence (N));
1039
1040                --  Loop ends the current statement sequence, but we include
1041                --  the iteration scheme if present in the current sequence.
1042                --  But the body of the loop starts a new sequence, since it
1043                --  may not be executed as part of the current sequence.
1044
1045                when N_Loop_Statement =>
1046                   if Present (Iteration_Scheme (N)) then
1047
1048                      --  If iteration scheme present, extend the current
1049                      --  statement sequence to include the iteration scheme
1050                      --  and process any decisions it contains.
1051
1052                      declare
1053                         ISC : constant Node_Id := Iteration_Scheme (N);
1054
1055                      begin
1056                         --  While statement
1057
1058                         if Present (Condition (ISC)) then
1059                            Extend_Statement_Sequence (N, ISC, 'W');
1060                            Process_Decisions (Condition (ISC), 'W');
1061
1062                         --  For statement
1063
1064                         else
1065                            Extend_Statement_Sequence (N, ISC, 'F');
1066                            Process_Decisions
1067                              (Loop_Parameter_Specification (ISC), 'X');
1068                         end if;
1069                      end;
1070                   end if;
1071
1072                   Set_Statement_Entry;
1073                   Traverse_Declarations_Or_Statements (Statements (N));
1074
1075                --  Pragma
1076
1077                when N_Pragma =>
1078                   Extend_Statement_Sequence (N, 'P');
1079
1080                   --  For pragmas Assert, Check, Precondition, and
1081                   --  Postcondition, we generate decision entries for the
1082                   --  condition only if the pragma is enabled. For now, we just
1083                   --  check Assertions_Enabled, which will be set to reflect
1084                   --  the presence of -gnata.
1085
1086                   --  Later we should move processing of the relevant pragmas
1087                   --  to Par_Prag, and properly set the flag Pragma_Enabled at
1088                   --  parse time, so that we can check this flag instead ???
1089
1090                   --  For all other pragmas, we always generate decision
1091                   --  entries for any embedded expressions.
1092
1093                   declare
1094                      Nam : constant Name_Id :=
1095                              Chars (Pragma_Identifier (N));
1096                      Arg : Node_Id := First (Pragma_Argument_Associations (N));
1097                   begin
1098                      case Nam is
1099                         when Name_Assert        |
1100                              Name_Check         |
1101                              Name_Precondition  |
1102                              Name_Postcondition =>
1103
1104                            if Nam = Name_Check then
1105                               Next (Arg);
1106                            end if;
1107
1108                            if Assertions_Enabled then
1109                               Process_Decisions (Expression (Arg), 'P');
1110                            end if;
1111
1112                         when others =>
1113                            Process_Decisions (N, 'X');
1114                      end case;
1115                   end;
1116
1117                --  All other cases, which extend the current statement sequence
1118                --  but do not terminate it, even if they have nested decisions.
1119
1120                when others =>
1121
1122                   --  Determine required type character code
1123
1124                   declare
1125                      Typ : Character;
1126
1127                   begin
1128                      case Nkind (N) is
1129                         when N_Full_Type_Declaration         |
1130                              N_Incomplete_Type_Declaration   |
1131                              N_Private_Type_Declaration      |
1132                              N_Private_Extension_Declaration =>
1133                            Typ := 't';
1134
1135                         when N_Subtype_Declaration           =>
1136                            Typ := 's';
1137
1138                         when N_Object_Declaration            =>
1139                            Typ := 'o';
1140
1141                         when N_Renaming_Declaration          =>
1142                            Typ := 'r';
1143
1144                         when N_Generic_Instantiation         =>
1145                            Typ := 'i';
1146
1147                         when others                          =>
1148                            Typ := ' ';
1149                      end case;
1150
1151                      Extend_Statement_Sequence (N, Typ);
1152                   end;
1153
1154                   --  Process any embedded decisions
1155
1156                   if Has_Decision (N) then
1157                      Process_Decisions (N, 'X');
1158                   end if;
1159             end case;
1160
1161             Next (N);
1162          end loop;
1163
1164          Set_Statement_Entry;
1165       end if;
1166    end Traverse_Declarations_Or_Statements;
1167
1168    ------------------------------------------
1169    -- Traverse_Generic_Package_Declaration --
1170    ------------------------------------------
1171
1172    procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
1173    begin
1174       Process_Decisions (Generic_Formal_Declarations (N), 'X');
1175       Traverse_Package_Declaration (N);
1176    end Traverse_Generic_Package_Declaration;
1177
1178    -----------------------------------------
1179    -- Traverse_Handled_Statement_Sequence --
1180    -----------------------------------------
1181
1182    procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
1183       Handler : Node_Id;
1184
1185    begin
1186
1187       --  For package bodies without a statement part, the parser adds an empty
1188       --  one, to normalize the representation. The null statement therein,
1189       --  which does not come from source, does not get a SCO.
1190
1191       if Present (N) and then Comes_From_Source (N) then
1192          Traverse_Declarations_Or_Statements (Statements (N));
1193
1194          if Present (Exception_Handlers (N)) then
1195             Handler := First (Exception_Handlers (N));
1196             while Present (Handler) loop
1197                Traverse_Declarations_Or_Statements (Statements (Handler));
1198                Next (Handler);
1199             end loop;
1200          end if;
1201       end if;
1202    end Traverse_Handled_Statement_Sequence;
1203
1204    ---------------------------
1205    -- Traverse_Package_Body --
1206    ---------------------------
1207
1208    procedure Traverse_Package_Body (N : Node_Id) is
1209    begin
1210       Traverse_Declarations_Or_Statements (Declarations (N));
1211       Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1212    end Traverse_Package_Body;
1213
1214    ----------------------------------
1215    -- Traverse_Package_Declaration --
1216    ----------------------------------
1217
1218    procedure Traverse_Package_Declaration (N : Node_Id) is
1219       Spec : constant Node_Id := Specification (N);
1220    begin
1221       Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
1222       Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
1223    end Traverse_Package_Declaration;
1224
1225    ------------------------------
1226    -- Traverse_Subprogram_Body --
1227    ------------------------------
1228
1229    procedure Traverse_Subprogram_Body (N : Node_Id) is
1230    begin
1231       Traverse_Declarations_Or_Statements (Declarations (N));
1232       Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1233    end Traverse_Subprogram_Body;
1234
1235 end Par_SCO;