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-2010, 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/Pragma 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, and similarly to get to pragmas to
  72    --  handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the
  73    --  conditions and pragmas in the table by their starting sloc, and use this
  74    --  hash table to map from these starting sloc values to SCO_Table indexes.
  75
  76    type Header_Num is new Integer range 0 .. 996;
  77    --  Type for hash table headers
  78
  79    function Hash (F : Source_Ptr) return Header_Num;
  80    --  Function to Hash source pointer value
  81
  82    function Equal (F1, F2 : Source_Ptr) return Boolean;
  83    --  Function to test two keys for equality
  84
  85    package Condition_Pragma_Hash_Table is new Simple_HTable
  86      (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
  87    --  The actual hash table
  88
  89    --------------------------
  90    -- Internal Subprograms --
  91    --------------------------
  92
  93    function Has_Decision (N : Node_Id) return Boolean;
  94    --  N is the node for a subexpression. Returns True if the subexpression
  95    --  contains a nested decision (i.e. either is a logical operator, or
  96    --  contains a logical operator in its subtree).
  97
  98    function Is_Logical_Operator (N : Node_Id) return Boolean;
  99    --  N is the node for a subexpression. This procedure just tests N to see
 100    --  if it is a logical operator (including short circuit conditions, but
 101    --  excluding OR and AND) and returns True if so, False otherwise, it does
 102    --  no other processing.
 103
 104    procedure Process_Decisions (N : Node_Id; T : Character);
 105    --  If N is Empty, has no effect. Otherwise scans the tree for the node N,
 106    --  to output any decisions it contains. T is one of IEPWX (for context of
 107    --  expresion: if/exit when/pragma/while/expression). If T is other than X,
 108    --  the node N is the conditional expression involved, and a decision is
 109    --  always present (at the very least a simple decision is present at the
 110    --  top level).
 111
 112    procedure Process_Decisions (L : List_Id; T : Character);
 113    --  Calls above procedure for each element of the list L
 114
 115    procedure Set_Table_Entry
 116      (C1   : Character;
 117       C2   : Character;
 118       From : Source_Ptr;
 119       To   : Source_Ptr;
 120       Last : Boolean);
 121    --  Append an entry to SCO_Table with fields set as per arguments
 122
 123    procedure Traverse_Declarations_Or_Statements  (L : List_Id);
 124    procedure Traverse_Generic_Instantiation       (N : Node_Id);
 125    procedure Traverse_Generic_Package_Declaration (N : Node_Id);
 126    procedure Traverse_Handled_Statement_Sequence  (N : Node_Id);
 127    procedure Traverse_Package_Body                (N : Node_Id);
 128    procedure Traverse_Package_Declaration         (N : Node_Id);
 129    procedure Traverse_Subprogram_Body             (N : Node_Id);
 130    procedure Traverse_Subprogram_Declaration      (N : Node_Id);
 131    --  Traverse the corresponding construct, generating SCO table entries
 132
 133    procedure Write_SCOs_To_ALI_File is new Put_SCOs;
 134    --  Write SCO information to the ALI file using routines in Lib.Util
 135
 136    ----------
 137    -- dsco --
 138    ----------
 139
 140    procedure dsco is
 141    begin
 142       --  Dump SCO unit table
 143
 144       Write_Line ("SCO Unit Table");
 145       Write_Line ("--------------");
 146
 147       for Index in 1 .. SCO_Unit_Table.Last loop
 148          declare
 149             UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
 150
 151          begin
 152             Write_Str ("  ");
 153             Write_Int (Int (Index));
 154             Write_Str (".  Dep_Num = ");
 155             Write_Int (Int (UTE.Dep_Num));
 156             Write_Str ("  From = ");
 157             Write_Int (Int (UTE.From));
 158             Write_Str ("  To = ");
 159             Write_Int (Int (UTE.To));
 160
 161             Write_Str ("  File_Name = """);
 162
 163             if UTE.File_Name /= null then
 164                Write_Str (UTE.File_Name.all);
 165             end if;
 166
 167             Write_Char ('"');
 168             Write_Eol;
 169          end;
 170       end loop;
 171
 172       --  Dump SCO Unit number table if it contains any entries
 173
 174       if SCO_Unit_Number_Table.Last >= 1 then
 175          Write_Eol;
 176          Write_Line ("SCO Unit Number Table");
 177          Write_Line ("---------------------");
 178
 179          for Index in 1 .. SCO_Unit_Number_Table.Last loop
 180             Write_Str ("  ");
 181             Write_Int (Int (Index));
 182             Write_Str (". Unit_Number = ");
 183             Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
 184             Write_Eol;
 185          end loop;
 186       end if;
 187
 188       --  Dump SCO table itself
 189
 190       Write_Eol;
 191       Write_Line ("SCO Table");
 192       Write_Line ("---------");
 193
 194       for Index in 1 .. SCO_Table.Last loop
 195          declare
 196             T : SCO_Table_Entry renames SCO_Table.Table (Index);
 197
 198          begin
 199             Write_Str  ("  ");
 200             Write_Int  (Index);
 201             Write_Char ('.');
 202
 203             if T.C1 /= ' ' then
 204                Write_Str  ("  C1 = '");
 205                Write_Char (T.C1);
 206                Write_Char (''');
 207             end if;
 208
 209             if T.C2 /= ' ' then
 210                Write_Str  ("  C2 = '");
 211                Write_Char (T.C2);
 212                Write_Char (''');
 213             end if;
 214
 215             if T.From /= No_Source_Location then
 216                Write_Str ("  From = ");
 217                Write_Int (Int (T.From.Line));
 218                Write_Char (':');
 219                Write_Int (Int (T.From.Col));
 220             end if;
 221
 222             if T.To /= No_Source_Location then
 223                Write_Str ("  To = ");
 224                Write_Int (Int (T.To.Line));
 225                Write_Char (':');
 226                Write_Int (Int (T.To.Col));
 227             end if;
 228
 229             if T.Last then
 230                Write_Str ("  True");
 231             else
 232                Write_Str ("  False");
 233             end if;
 234
 235             Write_Eol;
 236          end;
 237       end loop;
 238    end dsco;
 239
 240    -----------
 241    -- Equal --
 242    -----------
 243
 244    function Equal (F1, F2 : Source_Ptr) return Boolean is
 245    begin
 246       return F1 = F2;
 247    end Equal;
 248
 249    ------------------
 250    -- Has_Decision --
 251    ------------------
 252
 253    function Has_Decision (N : Node_Id) return Boolean is
 254
 255       function Check_Node (N : Node_Id) return Traverse_Result;
 256
 257       ----------------
 258       -- Check_Node --
 259       ----------------
 260
 261       function Check_Node (N : Node_Id) return Traverse_Result is
 262       begin
 263          if Is_Logical_Operator (N) then
 264             return Abandon;
 265          else
 266             return OK;
 267          end if;
 268       end Check_Node;
 269
 270       function Traverse is new Traverse_Func (Check_Node);
 271
 272    --  Start of processing for Has_Decision
 273
 274    begin
 275       return Traverse (N) = Abandon;
 276    end Has_Decision;
 277
 278    ----------
 279    -- Hash --
 280    ----------
 281
 282    function Hash (F : Source_Ptr) return Header_Num is
 283    begin
 284       return Header_Num (Nat (F) mod 997);
 285    end Hash;
 286
 287    ----------------
 288    -- Initialize --
 289    ----------------
 290
 291    procedure Initialize is
 292    begin
 293       SCO_Unit_Number_Table.Init;
 294
 295       --  Set dummy 0'th entry in place for sort
 296
 297       SCO_Unit_Number_Table.Increment_Last;
 298    end Initialize;
 299
 300    -------------------------
 301    -- Is_Logical_Operator --
 302    -------------------------
 303
 304    function Is_Logical_Operator (N : Node_Id) return Boolean is
 305    begin
 306       return Nkind_In (N, N_Op_Not,
 307                           N_And_Then,
 308                           N_Or_Else);
 309    end Is_Logical_Operator;
 310
 311    -----------------------
 312    -- Process_Decisions --
 313    -----------------------
 314
 315    --  Version taking a list
 316
 317    procedure Process_Decisions (L : List_Id; T : Character) is
 318       N : Node_Id;
 319    begin
 320       if L /= No_List then
 321          N := First (L);
 322          while Present (N) loop
 323             Process_Decisions (N, T);
 324             Next (N);
 325          end loop;
 326       end if;
 327    end Process_Decisions;
 328
 329    --  Version taking a node
 330
 331    procedure Process_Decisions (N : Node_Id; T : Character) is
 332
 333       Mark : Nat;
 334       --  This is used to mark the location of a decision sequence in the SCO
 335       --  table. We use it for backing out a simple decision in an expression
 336       --  context that contains only NOT operators.
 337
 338       X_Not_Decision : Boolean;
 339       --  This flag keeps track of whether a decision sequence in the SCO table
 340       --  contains only NOT operators, and is for an expression context (T=X).
 341       --  The flag will be set False if T is other than X, or if an operator
 342       --  other than NOT is in the sequence.
 343
 344       function Process_Node (N : Node_Id) return Traverse_Result;
 345       --  Processes one node in the traversal, looking for logical operators,
 346       --  and if one is found, outputs the appropriate table entries.
 347
 348       procedure Output_Decision_Operand (N : Node_Id);
 349       --  The node N is the top level logical operator of a decision, or it is
 350       --  one of the operands of a logical operator belonging to a single
 351       --  complex decision. This routine outputs the sequence of table entries
 352       --  corresponding to the node. Note that we do not process the sub-
 353       --  operands to look for further decisions, that processing is done in
 354       --  Process_Decision_Operand, because we can't get decisions mixed up in
 355       --  the global table. Call has no effect if N is Empty.
 356
 357       procedure Output_Element (N : Node_Id);
 358       --  Node N is an operand of a logical operator that is not itself a
 359       --  logical operator, or it is a simple decision. This routine outputs
 360       --  the table entry for the element, with C1 set to ' '. Last is set
 361       --  False, and an entry is made in the condition hash table.
 362
 363       procedure Output_Header (T : Character);
 364       --  Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
 365       --  PRAGMA, and 'X' for the expression case.
 366
 367       procedure Process_Decision_Operand (N : Node_Id);
 368       --  This is called on node N, the top level node of a decision, or on one
 369       --  of its operands or suboperands after generating the full output for
 370       --  the complex decision. It process the suboperands of the decision
 371       --  looking for nested decisions.
 372
 373       -----------------------------
 374       -- Output_Decision_Operand --
 375       -----------------------------
 376
 377       procedure Output_Decision_Operand (N : Node_Id) is
 378          C : Character;
 379          L : Node_Id;
 380
 381       begin
 382          if No (N) then
 383             return;
 384
 385          --  Logical operator
 386
 387          elsif Is_Logical_Operator (N) then
 388             if Nkind (N) = N_Op_Not then
 389                C := '!';
 390                L := Empty;
 391
 392             else
 393                L := Left_Opnd (N);
 394
 395                if Nkind_In (N, N_Op_Or, N_Or_Else) then
 396                   C := '|';
 397                else
 398                   C := '&';
 399                end if;
 400             end if;
 401
 402             Set_Table_Entry
 403               (C1   => C,
 404                C2   => ' ',
 405                From => Sloc (N),
 406                To   => No_Location,
 407                Last => False);
 408
 409             Output_Decision_Operand (L);
 410             Output_Decision_Operand (Right_Opnd (N));
 411
 412          --  Not a logical operator
 413
 414          else
 415             Output_Element (N);
 416          end if;
 417       end Output_Decision_Operand;
 418
 419       --------------------
 420       -- Output_Element --
 421       --------------------
 422
 423       procedure Output_Element (N : Node_Id) is
 424          FSloc : Source_Ptr;
 425          LSloc : Source_Ptr;
 426       begin
 427          Sloc_Range (N, FSloc, LSloc);
 428          Set_Table_Entry
 429            (C1   => ' ',
 430             C2   => 'c',
 431             From => FSloc,
 432             To   => LSloc,
 433             Last => False);
 434          Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last);
 435       end Output_Element;
 436
 437       -------------------
 438       -- Output_Header --
 439       -------------------
 440
 441       procedure Output_Header (T : Character) is
 442       begin
 443          case T is
 444             when 'I' | 'E' | 'W' =>
 445
 446                --  For IF, EXIT, WHILE, the token SLOC can be found from
 447                --  the SLOC of the parent of the expression.
 448
 449                Set_Table_Entry
 450                  (C1   => T,
 451                   C2   => ' ',
 452                   From => Sloc (Parent (N)),
 453                   To   => No_Location,
 454                   Last => False);
 455
 456             when 'P' =>
 457
 458                --  For PRAGMA, we must get the location from the pragma node.
 459                --  Argument N is the pragma argument, and we have to go up two
 460                --  levels (through the pragma argument association) to get to
 461                --  the pragma node itself.
 462
 463                declare
 464                   Loc : constant Source_Ptr := Sloc (Parent (Parent (N)));
 465
 466                begin
 467                   Set_Table_Entry
 468                     (C1   => 'P',
 469                      C2   => 'd',
 470                      From => Loc,
 471                      To   => No_Location,
 472                      Last => False);
 473
 474                   --  For pragmas we also must make an entry in the hash table
 475                   --  for later access by Set_SCO_Pragma_Enabled. We set the
 476                   --  pragma as disabled above, the call will change C2 to 'e'
 477                   --  to enable the pragma header entry.
 478
 479                   Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
 480                end;
 481
 482             when 'X' =>
 483
 484                --  For an expression, no Sloc
 485
 486                Set_Table_Entry
 487                  (C1   => 'X',
 488                   C2   => ' ',
 489                   From => No_Location,
 490                   To   => No_Location,
 491                   Last => False);
 492
 493             --  No other possibilities
 494
 495             when others =>
 496                raise Program_Error;
 497          end case;
 498       end Output_Header;
 499
 500       ------------------------------
 501       -- Process_Decision_Operand --
 502       ------------------------------
 503
 504       procedure Process_Decision_Operand (N : Node_Id) is
 505       begin
 506          if Is_Logical_Operator (N) then
 507             if Nkind (N) /= N_Op_Not then
 508                Process_Decision_Operand (Left_Opnd (N));
 509                X_Not_Decision := False;
 510             end if;
 511
 512             Process_Decision_Operand (Right_Opnd (N));
 513
 514          else
 515             Process_Decisions (N, 'X');
 516          end if;
 517       end Process_Decision_Operand;
 518
 519       ------------------
 520       -- Process_Node --
 521       ------------------
 522
 523       function Process_Node (N : Node_Id) return Traverse_Result is
 524       begin
 525          case Nkind (N) is
 526
 527                --  Logical operators, output table entries and then process
 528                --  operands recursively to deal with nested conditions.
 529
 530             when N_And_Then |
 531                  N_Or_Else  |
 532                  N_Op_Not   =>
 533
 534                declare
 535                   T : Character;
 536
 537                begin
 538                   --  If outer level, then type comes from call, otherwise it
 539                   --  is more deeply nested and counts as X for expression.
 540
 541                   if N = Process_Decisions.N then
 542                      T := Process_Decisions.T;
 543                   else
 544                      T := 'X';
 545                   end if;
 546
 547                   --  Output header for sequence
 548
 549                   X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
 550                   Mark := SCO_Table.Last;
 551                   Output_Header (T);
 552
 553                   --  Output the decision
 554
 555                   Output_Decision_Operand (N);
 556
 557                   --  If the decision was in an expression context (T = 'X')
 558                   --  and contained only NOT operators, then we don't output
 559                   --  it, so delete it.
 560
 561                   if X_Not_Decision then
 562                      SCO_Table.Set_Last (Mark);
 563
 564                   --  Otherwise, set Last in last table entry to mark end
 565
 566                   else
 567                      SCO_Table.Table (SCO_Table.Last).Last := True;
 568                   end if;
 569
 570                   --  Process any embedded decisions
 571
 572                   Process_Decision_Operand (N);
 573                   return Skip;
 574                end;
 575
 576             --  Case expression
 577
 578             when N_Case_Expression =>
 579                return OK; -- ???
 580
 581             --  Conditional expression, processed like an if statement
 582
 583             when N_Conditional_Expression =>
 584                declare
 585                   Cond : constant Node_Id := First (Expressions (N));
 586                   Thnx : constant Node_Id := Next (Cond);
 587                   Elsx : constant Node_Id := Next (Thnx);
 588                begin
 589                   Process_Decisions (Cond, 'I');
 590                   Process_Decisions (Thnx, 'X');
 591                   Process_Decisions (Elsx, 'X');
 592                   return Skip;
 593                end;
 594
 595             --  All other cases, continue scan
 596
 597             when others =>
 598                return OK;
 599
 600          end case;
 601       end Process_Node;
 602
 603       procedure Traverse is new Traverse_Proc (Process_Node);
 604
 605    --  Start of processing for Process_Decisions
 606
 607    begin
 608       if No (N) then
 609          return;
 610       end if;
 611
 612       --  See if we have simple decision at outer level and if so then
 613       --  generate the decision entry for this simple decision. A simple
 614       --  decision is a boolean expression (which is not a logical operator
 615       --  or short circuit form) appearing as the operand of an IF, WHILE,
 616       --  EXIT WHEN, or special PRAGMA construct.
 617
 618       if T /= 'X' and then not Is_Logical_Operator (N) then
 619          Output_Header (T);
 620          Output_Element (N);
 621
 622          --  Change Last in last table entry to True to mark end of
 623          --  sequence, which is this case is only one element long.
 624
 625          SCO_Table.Table (SCO_Table.Last).Last := True;
 626       end if;
 627
 628       Traverse (N);
 629    end Process_Decisions;
 630
 631    -----------
 632    -- pscos --
 633    -----------
 634
 635    procedure pscos is
 636
 637       procedure Write_Info_Char (C : Character) renames Write_Char;
 638       --  Write one character;
 639
 640       procedure Write_Info_Initiate (Key : Character) renames Write_Char;
 641       --  Start new one and write one character;
 642
 643       procedure Write_Info_Nat (N : Nat);
 644       --  Write value of N
 645
 646       procedure Write_Info_Terminate renames Write_Eol;
 647       --  Terminate current line
 648
 649       --------------------
 650       -- Write_Info_Nat --
 651       --------------------
 652
 653       procedure Write_Info_Nat (N : Nat) is
 654       begin
 655          Write_Int (N);
 656       end Write_Info_Nat;
 657
 658       procedure Debug_Put_SCOs is new Put_SCOs;
 659
 660       --  Start of processing for pscos
 661
 662    begin
 663       Debug_Put_SCOs;
 664    end pscos;
 665
 666    ----------------
 667    -- SCO_Output --
 668    ----------------
 669
 670    procedure SCO_Output is
 671    begin
 672       if Debug_Flag_Dot_OO then
 673          dsco;
 674       end if;
 675
 676       --  Sort the unit tables based on dependency numbers
 677
 678       Unit_Table_Sort : declare
 679
 680          function Lt (Op1, Op2 : Natural) return Boolean;
 681          --  Comparison routine for sort call
 682
 683          procedure Move (From : Natural; To : Natural);
 684          --  Move routine for sort call
 685
 686          --------
 687          -- Lt --
 688          --------
 689
 690          function Lt (Op1, Op2 : Natural) return Boolean is
 691          begin
 692             return
 693               Dependency_Num
 694                 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
 695                      <
 696               Dependency_Num
 697                 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
 698          end Lt;
 699
 700          ----------
 701          -- Move --
 702          ----------
 703
 704          procedure Move (From : Natural; To : Natural) is
 705          begin
 706             SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
 707               SCO_Unit_Table.Table (SCO_Unit_Index (From));
 708             SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
 709               SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
 710          end Move;
 711
 712          package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
 713
 714       --  Start of processing for Unit_Table_Sort
 715
 716       begin
 717          Sorting.Sort (Integer (SCO_Unit_Table.Last));
 718       end Unit_Table_Sort;
 719
 720       --  Loop through entries in the unit table to set file name and
 721       --  dependency number entries.
 722
 723       for J in 1 .. SCO_Unit_Table.Last loop
 724          declare
 725             U   : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
 726             UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
 727          begin
 728             Get_Name_String (Reference_Name (Source_Index (U)));
 729             UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
 730             UTE.Dep_Num := Dependency_Num (U);
 731          end;
 732       end loop;
 733
 734       --  Now the tables are all setup for output to the ALI file
 735
 736       Write_SCOs_To_ALI_File;
 737    end SCO_Output;
 738
 739    ----------------
 740    -- SCO_Record --
 741    ----------------
 742
 743    procedure SCO_Record (U : Unit_Number_Type) is
 744       Lu   : Node_Id;
 745       From : Nat;
 746
 747    begin
 748       --  Ignore call if not generating code and generating SCO's
 749
 750       if not (Generate_SCO and then Operating_Mode = Generate_Code) then
 751          return;
 752       end if;
 753
 754       --  Ignore call if this unit already recorded
 755
 756       for J in 1 .. SCO_Unit_Number_Table.Last loop
 757          if U = SCO_Unit_Number_Table.Table (J) then
 758             return;
 759          end if;
 760       end loop;
 761
 762       --  Otherwise record starting entry
 763
 764       From := SCO_Table.Last + 1;
 765
 766       --  Get Unit (checking case of subunit)
 767
 768       Lu := Unit (Cunit (U));
 769
 770       if Nkind (Lu) = N_Subunit then
 771          Lu := Proper_Body (Lu);
 772       end if;
 773
 774       --  Traverse the unit
 775
 776       if Nkind (Lu) = N_Subprogram_Body then
 777          Traverse_Subprogram_Body (Lu);
 778
 779       elsif Nkind (Lu) = N_Subprogram_Declaration then
 780          Traverse_Subprogram_Declaration (Lu);
 781
 782       elsif Nkind (Lu) = N_Package_Declaration then
 783          Traverse_Package_Declaration (Lu);
 784
 785       elsif Nkind (Lu) = N_Package_Body then
 786          Traverse_Package_Body (Lu);
 787
 788       elsif Nkind (Lu) = N_Generic_Package_Declaration then
 789          Traverse_Generic_Package_Declaration (Lu);
 790
 791       elsif Nkind (Lu) in N_Generic_Instantiation then
 792          Traverse_Generic_Instantiation (Lu);
 793
 794       --  All other cases of compilation units (e.g. renamings), generate
 795       --  no SCO information.
 796
 797       else
 798          null;
 799       end if;
 800
 801       --  Make entry for new unit in unit tables, we will fill in the file
 802       --  name and dependency numbers later.
 803
 804       SCO_Unit_Table.Append (
 805         (Dep_Num   => 0,
 806          File_Name => null,
 807          From      => From,
 808          To        => SCO_Table.Last));
 809
 810       SCO_Unit_Number_Table.Append (U);
 811    end SCO_Record;
 812
 813    -----------------------
 814    -- Set_SCO_Condition --
 815    -----------------------
 816
 817    procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
 818       Orig  : constant Node_Id := Original_Node (Cond);
 819       Index : Nat;
 820       Start : Source_Ptr;
 821       Dummy : Source_Ptr;
 822
 823       Constant_Condition_Code : constant array (Boolean) of Character :=
 824                                   (False => 'f', True => 't');
 825    begin
 826       Sloc_Range (Orig, Start, Dummy);
 827       Index := Condition_Pragma_Hash_Table.Get (Start);
 828
 829       --  The test here for zero is to deal with possible previous errors
 830
 831       if Index /= 0 then
 832          pragma Assert (SCO_Table.Table (Index).C1 = ' ');
 833          SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val);
 834       end if;
 835    end Set_SCO_Condition;
 836
 837    ----------------------------
 838    -- Set_SCO_Pragma_Enabled --
 839    ----------------------------
 840
 841    procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
 842       Index : Nat;
 843
 844    begin
 845       --  Note: the reason we use the Sloc value as the key is that in the
 846       --  generic case, the call to this procedure is made on a copy of the
 847       --  original node, so we can't use the Node_Id value.
 848
 849       Index := Condition_Pragma_Hash_Table.Get (Loc);
 850
 851       --  The test here for zero is to deal with possible previous errors
 852
 853       if Index /= 0 then
 854          pragma Assert (SCO_Table.Table (Index).C1 = 'P');
 855          SCO_Table.Table (Index).C2 := 'e';
 856       end if;
 857    end Set_SCO_Pragma_Enabled;
 858
 859    ---------------------
 860    -- Set_Table_Entry --
 861    ---------------------
 862
 863    procedure Set_Table_Entry
 864      (C1   : Character;
 865       C2   : Character;
 866       From : Source_Ptr;
 867       To   : Source_Ptr;
 868       Last : Boolean)
 869    is
 870       function To_Source_Location (S : Source_Ptr) return Source_Location;
 871       --  Converts Source_Ptr value to Source_Location (line/col) format
 872
 873       ------------------------
 874       -- To_Source_Location --
 875       ------------------------
 876
 877       function To_Source_Location (S : Source_Ptr) return Source_Location is
 878       begin
 879          if S = No_Location then
 880             return No_Source_Location;
 881          else
 882             return
 883               (Line => Get_Logical_Line_Number (S),
 884                Col  => Get_Column_Number (S));
 885          end if;
 886       end To_Source_Location;
 887
 888    --  Start of processing for Set_Table_Entry
 889
 890    begin
 891       Add_SCO
 892         (C1   => C1,
 893          C2   => C2,
 894          From => To_Source_Location (From),
 895          To   => To_Source_Location (To),
 896          Last => Last);
 897    end Set_Table_Entry;
 898
 899    -----------------------------------------
 900    -- Traverse_Declarations_Or_Statements --
 901    -----------------------------------------
 902
 903    --  Tables used by Traverse_Declarations_Or_Statements for temporarily
 904    --  holding statement and decision entries. These are declared globally
 905    --  since they are shared by recursive calls to this procedure.
 906
 907    type SC_Entry is record
 908       From : Source_Ptr;
 909       To   : Source_Ptr;
 910       Typ  : Character;
 911    end record;
 912    --  Used to store a single entry in the following table, From:To represents
 913    --  the range of entries in the CS line entry, and typ is the type, with
 914    --  space meaning that no type letter will accompany the entry.
 915
 916    package SC is new Table.Table (
 917      Table_Component_Type => SC_Entry,
 918      Table_Index_Type     => Nat,
 919      Table_Low_Bound      => 1,
 920      Table_Initial        => 1000,
 921      Table_Increment      => 200,
 922      Table_Name           => "SCO_SC");
 923       --  Used to store statement components for a CS entry to be output
 924       --  as a result of the call to this procedure. SC.Last is the last
 925       --  entry stored, so the current statement sequence is represented
 926       --  by SC_Array (SC_First .. SC.Last), where SC_First is saved on
 927       --  entry to each recursive call to the routine.
 928       --
 929       --  Extend_Statement_Sequence adds an entry to this array, and then
 930       --  Set_Statement_Entry clears the entries starting with SC_First,
 931       --  copying these entries to the main SCO output table. The reason that
 932       --  we do the temporary caching of results in this array is that we want
 933       --  the SCO table entries for a given CS line to be contiguous, and the
 934       --  processing may output intermediate entries such as decision entries.
 935
 936    type SD_Entry is record
 937       Nod : Node_Id;
 938       Lst : List_Id;
 939       Typ : Character;
 940    end record;
 941    --  Used to store a single entry in the following table. Nod is the node to
 942    --  be searched for decisions for the case of Process_Decisions_Defer with a
 943    --  node argument (with Lst set to No_List. Lst is the list to be searched
 944    --  for decisions for the case of Process_Decisions_Defer with a List
 945    --  argument (in which case Nod is set to Empty).
 946
 947    package SD is new Table.Table (
 948      Table_Component_Type => SD_Entry,
 949      Table_Index_Type     => Nat,
 950      Table_Low_Bound      => 1,
 951      Table_Initial        => 1000,
 952      Table_Increment      => 200,
 953      Table_Name           => "SCO_SD");
 954    --  Used to store possible decision information. Instead of calling the
 955    --  Process_Decisions procedures directly, we call Process_Decisions_Defer,
 956    --  which simply stores the arguments in this table. Then when we clear
 957    --  out a statement sequence using Set_Statement_Entry, after generating
 958    --  the CS lines for the statements, the entries in this table result in
 959    --  calls to Process_Decision. The reason for doing things this way is to
 960    --  ensure that decisions are output after the CS line for the statements
 961    --  in which the decisions occur.
 962
 963    procedure Traverse_Declarations_Or_Statements (L : List_Id) is
 964       N     : Node_Id;
 965       Dummy : Source_Ptr;
 966
 967       SC_First : constant Nat := SC.Last + 1;
 968       SD_First : constant Nat := SD.Last + 1;
 969       --  Record first entries used in SC/SD at this recursive level
 970
 971       procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
 972       --  Extend the current statement sequence to encompass the node N. Typ
 973       --  is the letter that identifies the type of statement/declaration that
 974       --  is being added to the sequence.
 975
 976       procedure Extend_Statement_Sequence
 977         (From : Node_Id;
 978          To   : Node_Id;
 979          Typ  : Character);
 980       --  This version extends the current statement sequence with an entry
 981       --  that starts with the first token of From, and ends with the last
 982       --  token of To. It is used for example in a CASE statement to cover
 983       --  the range from the CASE token to the last token of the expression.
 984
 985       procedure Set_Statement_Entry;
 986       --  If Start is No_Location, does nothing, otherwise outputs a SCO_Table
 987       --  statement entry for the range Start-Stop and then sets both Start
 988       --  and Stop to No_Location. Unconditionally sets Term to True. This is
 989       --  called when we find a statement or declaration that generates its
 990       --  own table entry, so that we must end the current statement sequence.
 991
 992       procedure Process_Decisions_Defer (N : Node_Id; T : Character);
 993       pragma Inline (Process_Decisions_Defer);
 994       --  This routine is logically the same as Process_Decisions, except that
 995       --  the arguments are saved in the SD table, for later processing when
 996       --  Set_Statement_Entry is called, which goes through the saved entries
 997       --  making the corresponding calls to Process_Decision.
 998
 999       procedure Process_Decisions_Defer (L : List_Id; T : Character);
1000       pragma Inline (Process_Decisions_Defer);
1001       --  Same case for list arguments, deferred call to Process_Decisions
1002
1003       -------------------------
1004       -- Set_Statement_Entry --
1005       -------------------------
1006
1007       procedure Set_Statement_Entry is
1008          C1      : Character;
1009          SC_Last : constant Int := SC.Last;
1010          SD_Last : constant Int := SD.Last;
1011
1012       begin
1013          --  Output statement entries from saved entries in SC table
1014
1015          for J in SC_First .. SC_Last loop
1016             if J = SC_First then
1017                C1 := 'S';
1018             else
1019                C1 := 's';
1020             end if;
1021
1022             declare
1023                SCE : SC_Entry renames SC.Table (J);
1024             begin
1025                Set_Table_Entry
1026                  (C1   => C1,
1027                   C2   => SCE.Typ,
1028                   From => SCE.From,
1029                   To   => SCE.To,
1030                   Last => (J = SC_Last));
1031             end;
1032          end loop;
1033
1034          --  Clear out used section of SC table
1035
1036          SC.Set_Last (SC_First - 1);
1037
1038          --  Output any embedded decisions
1039
1040          for J in SD_First .. SD_Last loop
1041             declare
1042                SDE : SD_Entry renames SD.Table (J);
1043             begin
1044                if Present (SDE.Nod) then
1045                   Process_Decisions (SDE.Nod, SDE.Typ);
1046                else
1047                   Process_Decisions (SDE.Lst, SDE.Typ);
1048                end if;
1049             end;
1050          end loop;
1051
1052          --  Clear out used section of SD table
1053
1054          SD.Set_Last (SD_First - 1);
1055       end Set_Statement_Entry;
1056
1057       -------------------------------
1058       -- Extend_Statement_Sequence --
1059       -------------------------------
1060
1061       procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1062          F : Source_Ptr;
1063          T : Source_Ptr;
1064       begin
1065          Sloc_Range (N, F, T);
1066          SC.Append ((F, T, Typ));
1067       end Extend_Statement_Sequence;
1068
1069       procedure Extend_Statement_Sequence
1070         (From : Node_Id;
1071          To   : Node_Id;
1072          Typ  : Character)
1073       is
1074          F : Source_Ptr;
1075          T : Source_Ptr;
1076       begin
1077          Sloc_Range (From, F, Dummy);
1078          Sloc_Range (To, Dummy, T);
1079          SC.Append ((F, T, Typ));
1080       end Extend_Statement_Sequence;
1081
1082       -----------------------------
1083       -- Process_Decisions_Defer --
1084       -----------------------------
1085
1086       procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1087       begin
1088          SD.Append ((N, No_List, T));
1089       end Process_Decisions_Defer;
1090
1091       procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1092       begin
1093          SD.Append ((Empty, L, T));
1094       end Process_Decisions_Defer;
1095
1096    --  Start of processing for Traverse_Declarations_Or_Statements
1097
1098    begin
1099       if Is_Non_Empty_List (L) then
1100
1101          --  Loop through statements or declarations
1102
1103          N := First (L);
1104          while Present (N) loop
1105
1106             --  Initialize or extend current statement sequence. Note that for
1107             --  special cases such as IF and Case statements we will modify
1108             --  the range to exclude internal statements that should not be
1109             --  counted as part of the current statement sequence.
1110
1111             case Nkind (N) is
1112
1113                --  Package declaration
1114
1115                when N_Package_Declaration =>
1116                   Set_Statement_Entry;
1117                   Traverse_Package_Declaration (N);
1118
1119                --  Generic package declaration
1120
1121                when N_Generic_Package_Declaration =>
1122                   Set_Statement_Entry;
1123                   Traverse_Generic_Package_Declaration (N);
1124
1125                --  Package body
1126
1127                when N_Package_Body =>
1128                   Set_Statement_Entry;
1129                   Traverse_Package_Body (N);
1130
1131                --  Subprogram declaration
1132
1133                when N_Subprogram_Declaration =>
1134                   Process_Decisions_Defer
1135                     (Parameter_Specifications (Specification (N)), 'X');
1136                   Set_Statement_Entry;
1137
1138                --  Generic subprogram declaration
1139
1140                when N_Generic_Subprogram_Declaration =>
1141                   Process_Decisions_Defer
1142                     (Generic_Formal_Declarations (N), 'X');
1143                   Process_Decisions_Defer
1144                     (Parameter_Specifications (Specification (N)), 'X');
1145                   Set_Statement_Entry;
1146
1147                --  Subprogram_Body
1148
1149                when N_Subprogram_Body =>
1150                   Set_Statement_Entry;
1151                   Traverse_Subprogram_Body (N);
1152
1153                --  Exit statement, which is an exit statement in the SCO sense,
1154                --  so it is included in the current statement sequence, but
1155                --  then it terminates this sequence. We also have to process
1156                --  any decisions in the exit statement expression.
1157
1158                when N_Exit_Statement =>
1159                   Extend_Statement_Sequence (N, ' ');
1160                   Process_Decisions_Defer (Condition (N), 'E');
1161                   Set_Statement_Entry;
1162
1163                --  Label, which breaks the current statement sequence, but the
1164                --  label itself is not included in the next statement sequence,
1165                --  since it generates no code.
1166
1167                when N_Label =>
1168                   Set_Statement_Entry;
1169
1170                --  Block statement, which breaks the current statement sequence
1171
1172                when N_Block_Statement =>
1173                   Set_Statement_Entry;
1174                   Traverse_Declarations_Or_Statements (Declarations (N));
1175                   Traverse_Handled_Statement_Sequence
1176                     (Handled_Statement_Sequence (N));
1177
1178                --  If statement, which breaks the current statement sequence,
1179                --  but we include the condition in the current sequence.
1180
1181                when N_If_Statement =>
1182                   Extend_Statement_Sequence (N, Condition (N), 'I');
1183                   Process_Decisions_Defer (Condition (N), 'I');
1184                   Set_Statement_Entry;
1185
1186                   --  Now we traverse the statements in the THEN part
1187
1188                   Traverse_Declarations_Or_Statements (Then_Statements (N));
1189
1190                   --  Loop through ELSIF parts if present
1191
1192                   if Present (Elsif_Parts (N)) then
1193                      declare
1194                         Elif : Node_Id := First (Elsif_Parts (N));
1195
1196                      begin
1197                         while Present (Elif) loop
1198
1199                            --  We generate a statement sequence for the
1200                            --  construct "ELSIF condition", so that we have
1201                            --  a statement for the resulting decisions.
1202
1203                            Extend_Statement_Sequence
1204                              (Elif, Condition (Elif), 'I');
1205                            Process_Decisions_Defer (Condition (Elif), 'I');
1206                            Set_Statement_Entry;
1207
1208                            --  Traverse the statements in the ELSIF
1209
1210                            Traverse_Declarations_Or_Statements
1211                              (Then_Statements (Elif));
1212                            Next (Elif);
1213                         end loop;
1214                      end;
1215                   end if;
1216
1217                   --  Finally traverse the ELSE statements if present
1218
1219                   Traverse_Declarations_Or_Statements (Else_Statements (N));
1220
1221                --  Case statement, which breaks the current statement sequence,
1222                --  but we include the expression in the current sequence.
1223
1224                when N_Case_Statement =>
1225                   Extend_Statement_Sequence (N, Expression (N), 'C');
1226                   Process_Decisions_Defer (Expression (N), 'X');
1227                   Set_Statement_Entry;
1228
1229                   --  Process case branches
1230
1231                   declare
1232                      Alt : Node_Id;
1233                   begin
1234                      Alt := First (Alternatives (N));
1235                      while Present (Alt) loop
1236                         Traverse_Declarations_Or_Statements (Statements (Alt));
1237                         Next (Alt);
1238                      end loop;
1239                   end;
1240
1241                --  Unconditional exit points, which are included in the current
1242                --  statement sequence, but then terminate it
1243
1244                when N_Requeue_Statement |
1245                     N_Goto_Statement    |
1246                     N_Raise_Statement   =>
1247                   Extend_Statement_Sequence (N, ' ');
1248                   Set_Statement_Entry;
1249
1250                --  Simple return statement. which is an exit point, but we
1251                --  have to process the return expression for decisions.
1252
1253                when N_Simple_Return_Statement =>
1254                   Extend_Statement_Sequence (N, ' ');
1255                   Process_Decisions_Defer (Expression (N), 'X');
1256                   Set_Statement_Entry;
1257
1258                --  Extended return statement
1259
1260                when N_Extended_Return_Statement =>
1261                   Extend_Statement_Sequence
1262                     (N, Last (Return_Object_Declarations (N)), 'R');
1263                   Process_Decisions_Defer
1264                     (Return_Object_Declarations (N), 'X');
1265                   Set_Statement_Entry;
1266
1267                   Traverse_Handled_Statement_Sequence
1268                     (Handled_Statement_Sequence (N));
1269
1270                --  Loop ends the current statement sequence, but we include
1271                --  the iteration scheme if present in the current sequence.
1272                --  But the body of the loop starts a new sequence, since it
1273                --  may not be executed as part of the current sequence.
1274
1275                when N_Loop_Statement =>
1276                   if Present (Iteration_Scheme (N)) then
1277
1278                      --  If iteration scheme present, extend the current
1279                      --  statement sequence to include the iteration scheme
1280                      --  and process any decisions it contains.
1281
1282                      declare
1283                         ISC : constant Node_Id := Iteration_Scheme (N);
1284
1285                      begin
1286                         --  While statement
1287
1288                         if Present (Condition (ISC)) then
1289                            Extend_Statement_Sequence (N, ISC, 'W');
1290                            Process_Decisions_Defer (Condition (ISC), 'W');
1291
1292                         --  For statement
1293
1294                         else
1295                            Extend_Statement_Sequence (N, ISC, 'F');
1296                            Process_Decisions_Defer
1297                              (Loop_Parameter_Specification (ISC), 'X');
1298                         end if;
1299                      end;
1300                   end if;
1301
1302                   Set_Statement_Entry;
1303                   Traverse_Declarations_Or_Statements (Statements (N));
1304
1305                --  Pragma
1306
1307                when N_Pragma =>
1308                   Extend_Statement_Sequence (N, 'P');
1309
1310                   --  Processing depends on the kind of pragma
1311
1312                   case Pragma_Name (N) is
1313                      when Name_Assert        |
1314                           Name_Check         |
1315                           Name_Precondition  |
1316                           Name_Postcondition =>
1317
1318                         --  For Assert/Check/Precondition/Postcondition, we
1319                         --  must generate a P entry for the decision. Note that
1320                         --  this is done unconditionally at this stage. Output
1321                         --  for disabled pragmas is suppressed later on, when
1322                         --  we output the decision line in Put_SCOs.
1323
1324                         declare
1325                            Nam : constant Name_Id :=
1326                                    Chars (Pragma_Identifier (N));
1327                            Arg : Node_Id :=
1328                                    First (Pragma_Argument_Associations (N));
1329
1330                         begin
1331                            if Nam = Name_Check then
1332                               Next (Arg);
1333                            end if;
1334
1335                            Process_Decisions_Defer (Expression (Arg), 'P');
1336                         end;
1337
1338                      --  For all other pragmas, we generate decision entries
1339                      --  for any embedded expressions.
1340
1341                      when others =>
1342                         Process_Decisions_Defer (N, 'X');
1343                   end case;
1344
1345                --  Object declaration. Ignored if Prev_Ids is set, since the
1346                --  parser generates multiple instances of the whole declaration
1347                --  if there is more than one identifier declared, and we only
1348                --  want one entry in the SCO's, so we take the first, for which
1349                --  Prev_Ids is False.
1350
1351                when N_Object_Declaration =>
1352                   if not Prev_Ids (N) then
1353                      Extend_Statement_Sequence (N, 'o');
1354
1355                      if Has_Decision (N) then
1356                         Process_Decisions_Defer (N, 'X');
1357                      end if;
1358                   end if;
1359
1360                --  All other cases, which extend the current statement sequence
1361                --  but do not terminate it, even if they have nested decisions.
1362
1363                when others =>
1364
1365                   --  Determine required type character code
1366
1367                   declare
1368                      Typ : Character;
1369
1370                   begin
1371                      case Nkind (N) is
1372                         when N_Full_Type_Declaration         |
1373                              N_Incomplete_Type_Declaration   |
1374                              N_Private_Type_Declaration      |
1375                              N_Private_Extension_Declaration =>
1376                            Typ := 't';
1377
1378                         when N_Subtype_Declaration           =>
1379                            Typ := 's';
1380
1381                         when N_Renaming_Declaration          =>
1382                            Typ := 'r';
1383
1384                         when N_Generic_Instantiation         =>
1385                            Typ := 'i';
1386
1387                         when others                          =>
1388                            Typ := ' ';
1389                      end case;
1390
1391                      Extend_Statement_Sequence (N, Typ);
1392                   end;
1393
1394                   --  Process any embedded decisions
1395
1396                   if Has_Decision (N) then
1397                      Process_Decisions_Defer (N, 'X');
1398                   end if;
1399             end case;
1400
1401             Next (N);
1402          end loop;
1403
1404          Set_Statement_Entry;
1405       end if;
1406    end Traverse_Declarations_Or_Statements;
1407
1408    ------------------------------------
1409    -- Traverse_Generic_Instantiation --
1410    ------------------------------------
1411
1412    procedure Traverse_Generic_Instantiation (N : Node_Id) is
1413       First : Source_Ptr;
1414       Last  : Source_Ptr;
1415
1416    begin
1417       --  First we need a statement entry to cover the instantiation
1418
1419       Sloc_Range (N, First, Last);
1420       Set_Table_Entry
1421         (C1   => 'S',
1422          C2   => ' ',
1423          From => First,
1424          To   => Last,
1425          Last => True);
1426
1427       --  Now output any embedded decisions
1428
1429       Process_Decisions (N, 'X');
1430    end Traverse_Generic_Instantiation;
1431
1432    ------------------------------------------
1433    -- Traverse_Generic_Package_Declaration --
1434    ------------------------------------------
1435
1436    procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
1437    begin
1438       Process_Decisions (Generic_Formal_Declarations (N), 'X');
1439       Traverse_Package_Declaration (N);
1440    end Traverse_Generic_Package_Declaration;
1441
1442    -----------------------------------------
1443    -- Traverse_Handled_Statement_Sequence --
1444    -----------------------------------------
1445
1446    procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
1447       Handler : Node_Id;
1448
1449    begin
1450       --  For package bodies without a statement part, the parser adds an empty
1451       --  one, to normalize the representation. The null statement therein,
1452       --  which does not come from source, does not get a SCO.
1453
1454       if Present (N) and then Comes_From_Source (N) then
1455          Traverse_Declarations_Or_Statements (Statements (N));
1456
1457          if Present (Exception_Handlers (N)) then
1458             Handler := First (Exception_Handlers (N));
1459             while Present (Handler) loop
1460                Traverse_Declarations_Or_Statements (Statements (Handler));
1461                Next (Handler);
1462             end loop;
1463          end if;
1464       end if;
1465    end Traverse_Handled_Statement_Sequence;
1466
1467    ---------------------------
1468    -- Traverse_Package_Body --
1469    ---------------------------
1470
1471    procedure Traverse_Package_Body (N : Node_Id) is
1472    begin
1473       Traverse_Declarations_Or_Statements (Declarations (N));
1474       Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1475    end Traverse_Package_Body;
1476
1477    ----------------------------------
1478    -- Traverse_Package_Declaration --
1479    ----------------------------------
1480
1481    procedure Traverse_Package_Declaration (N : Node_Id) is
1482       Spec : constant Node_Id := Specification (N);
1483    begin
1484       Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
1485       Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
1486    end Traverse_Package_Declaration;
1487
1488    ------------------------------
1489    -- Traverse_Subprogram_Body --
1490    ------------------------------
1491
1492    procedure Traverse_Subprogram_Body (N : Node_Id) is
1493    begin
1494       Traverse_Declarations_Or_Statements (Declarations (N));
1495       Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1496    end Traverse_Subprogram_Body;
1497
1498    -------------------------------------
1499    -- Traverse_Subprogram_Declaration --
1500    -------------------------------------
1501
1502    procedure Traverse_Subprogram_Declaration (N : Node_Id) is
1503       ADN : constant Node_Id := Aux_Decls_Node (Parent (N));
1504    begin
1505       Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
1506       Traverse_Declarations_Or_Statements (Declarations   (ADN));
1507       Traverse_Declarations_Or_Statements (Pragmas_After  (ADN));
1508    end Traverse_Subprogram_Declaration;
1509
1510 end Par_SCO;