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-2014, 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 Aspects;  use Aspects;
  27 with Atree;    use Atree;
  28 with Debug;    use Debug;
  29 with Errout;   use Errout;
  30 with Lib;      use Lib;
  31 with Lib.Util; use Lib.Util;
  32 with Namet;    use Namet;
  33 with Nlists;   use Nlists;
  34 with Opt;      use Opt;
  35 with Output;   use Output;
  36 with Put_SCOs;
  37 with SCOs;     use SCOs;
  38 with Sem;      use Sem;
  39 with Sem_Util; use Sem_Util;
  40 with Sinfo;    use Sinfo;
  41 with Sinput;   use Sinput;
  42 with Snames;   use Snames;
  43 with Table;
  44
  45 with GNAT.HTable;      use GNAT.HTable;
  46 with GNAT.Heap_Sort_G;
  47 with GNAT.Table;
  48
  49 package body Par_SCO is
  50
  51    --------------------------
  52    -- First-pass SCO table --
  53    --------------------------
  54
  55    --  The Short_Circuit_And_Or pragma enables one to use AND and OR operators
  56    --  in source code while the ones used with booleans will be interpreted as
  57    --  their short circuit alternatives (AND THEN and OR ELSE). Thus, the true
  58    --  meaning of these operators is known only after the semantic analysis.
  59
  60    --  However, decision SCOs include short circuit operators only. The SCO
  61    --  information generation pass must be done before expansion, hence before
  62    --  the semantic analysis. Because of this, the SCO information generation
  63    --  is done in two passes.
  64
  65    --  The first one (SCO_Record_Raw, before semantic analysis) completes the
  66    --  SCO_Raw_Table assuming all AND/OR operators are short circuit ones.
  67    --  Then, the semantic analysis determines which operators are promoted to
  68    --  short circuit ones. Finally, the second pass (SCO_Record_Filtered)
  69    --  translates the SCO_Raw_Table to SCO_Table, taking care of removing the
  70    --  remaining AND/OR operators and of adjusting decisions accordingly
  71    --  (splitting decisions, removing empty ones, etc.).
  72
  73    type SCO_Generation_State_Type is (None, Raw, Filtered);
  74    SCO_Generation_State : SCO_Generation_State_Type := None;
  75    --  Keep track of the SCO generation state: this will prevent us from
  76    --  running some steps multiple times (the second pass has to be started
  77    --  from multiple places).
  78
  79    package SCO_Raw_Table is new GNAT.Table (
  80      Table_Component_Type => SCO_Table_Entry,
  81      Table_Index_Type     => Nat,
  82      Table_Low_Bound      => 1,
  83      Table_Initial        => 500,
  84      Table_Increment      => 300);
  85
  86    -----------------------
  87    -- Unit Number Table --
  88    -----------------------
  89
  90    --  This table parallels the SCO_Unit_Table, keeping track of the unit
  91    --  numbers corresponding to the entries made in this table, so that before
  92    --  writing out the SCO information to the ALI file, we can fill in the
  93    --  proper dependency numbers and file names.
  94
  95    --  Note that the zero'th entry is here for convenience in sorting the
  96    --  table, the real lower bound is 1.
  97
  98    package SCO_Unit_Number_Table is new Table.Table (
  99      Table_Component_Type => Unit_Number_Type,
 100      Table_Index_Type     => SCO_Unit_Index,
 101      Table_Low_Bound      => 0, -- see note above on sort
 102      Table_Initial        => 20,
 103      Table_Increment      => 200,
 104      Table_Name           => "SCO_Unit_Number_Entry");
 105
 106    ------------------------------------------
 107    -- Condition/Operator/Pragma Hash Table --
 108    ------------------------------------------
 109
 110    --  We need to be able to get to conditions quickly for handling the calls
 111    --  to Set_SCO_Condition efficiently, and similarly to get to pragmas to
 112    --  handle calls to Set_SCO_Pragma_Enabled (the same holds for operators and
 113    --  Set_SCO_Logical_Operator). For this purpose we identify the conditions,
 114    --  operators and pragmas in the table by their starting sloc, and use this
 115    --  hash table to map from these sloc values to SCO_Table indexes.
 116
 117    type Header_Num is new Integer range 0 .. 996;
 118    --  Type for hash table headers
 119
 120    function Hash (F : Source_Ptr) return Header_Num;
 121    --  Function to Hash source pointer value
 122
 123    function Equal (F1, F2 : Source_Ptr) return Boolean;
 124    --  Function to test two keys for equality
 125
 126    function "<" (S1, S2 : Source_Location) return Boolean;
 127    --  Function to test for source locations order
 128
 129    package SCO_Raw_Hash_Table is new Simple_HTable
 130      (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
 131    --  The actual hash table
 132
 133    --------------------------
 134    -- Internal Subprograms --
 135    --------------------------
 136
 137    function Has_Decision (N : Node_Id) return Boolean;
 138    --  N is the node for a subexpression. Returns True if the subexpression
 139    --  contains a nested decision (i.e. either is a logical operator, or
 140    --  contains a logical operator in its subtree).
 141    --
 142    --  This must be used in the first pass (SCO_Record_Raw) only: here AND/OR
 143    --  operators are considered as short circuit, just in case the
 144    --  Short_Circuit_And_Or pragma is used: only real short circuit operations
 145    --  will be kept in the secord pass.
 146
 147    type Tristate is (False, True, Unknown);
 148
 149    function Is_Logical_Operator (N : Node_Id) return Tristate;
 150    --  N is the node for a subexpression. This procedure determines whether N
 151    --  is a logical operator: True for short circuit conditions, Unknown for OR
 152    --  and AND (the Short_Circuit_And_Or pragma may be used) and False
 153    --  otherwise. Note that in cases where True is returned, callers assume
 154    --  Nkind (N) in N_Op.
 155
 156    function To_Source_Location (S : Source_Ptr) return Source_Location;
 157    --  Converts Source_Ptr value to Source_Location (line/col) format
 158
 159    procedure Process_Decisions
 160      (N           : Node_Id;
 161       T           : Character;
 162       Pragma_Sloc : Source_Ptr);
 163    --  If N is Empty, has no effect. Otherwise scans the tree for the node N,
 164    --  to output any decisions it contains. T is one of IEGPWX (for context of
 165    --  expression: if/exit when/entry guard/pragma/while/expression). If T is
 166    --  other than X, the node N is the if expression involved, and a decision
 167    --  is always present (at the very least a simple decision is present at the
 168    --  top level).
 169
 170    procedure Process_Decisions
 171      (L           : List_Id;
 172       T           : Character;
 173       Pragma_Sloc : Source_Ptr);
 174    --  Calls above procedure for each element of the list L
 175
 176    procedure Set_Raw_Table_Entry
 177      (C1                 : Character;
 178       C2                 : Character;
 179       From               : Source_Ptr;
 180       To                 : Source_Ptr;
 181       Last               : Boolean;
 182       Pragma_Sloc        : Source_Ptr := No_Location;
 183       Pragma_Aspect_Name : Name_Id    := No_Name);
 184    --  Append an entry to SCO_Raw_Table with fields set as per arguments
 185
 186    type Dominant_Info is record
 187       K : Character;
 188       --  F/T/S/E for a valid dominance marker, or ' ' for no dominant
 189
 190       N : Node_Id;
 191       --  Node providing the Sloc(s) for the dominance marker
 192    end record;
 193    No_Dominant : constant Dominant_Info := (' ', Empty);
 194
 195    procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr);
 196    --  Add one entry from the instance table to the corresponding SCO table
 197
 198    procedure Traverse_Declarations_Or_Statements
 199      (L : List_Id;
 200       D : Dominant_Info := No_Dominant;
 201       P : Node_Id       := Empty);
 202    --  Process L, a list of statements or declarations dominated by D.
 203    --  If P is present, it is processed as though it had been prepended to L.
 204
 205    function Traverse_Declarations_Or_Statements
 206      (L : List_Id;
 207       D : Dominant_Info := No_Dominant;
 208       P : Node_Id       := Empty) return Dominant_Info;
 209    --  Same as above, and returns dominant information corresponding to the
 210    --  last node with SCO in L.
 211
 212    --  The following Traverse_* routines perform appropriate calls to
 213    --  Traverse_Declarations_Or_Statements to traverse specific node kinds.
 214    --  Parameter D, when present, indicates the dominant of the first
 215    --  declaration or statement within N.
 216
 217    --  Why is Traverse_Sync_Definition commented specificaly and
 218    --   the others are not???
 219
 220    procedure Traverse_Generic_Package_Declaration (N : Node_Id);
 221    procedure Traverse_Handled_Statement_Sequence
 222      (N : Node_Id;
 223       D : Dominant_Info := No_Dominant);
 224    procedure Traverse_Package_Body        (N : Node_Id);
 225    procedure Traverse_Package_Declaration
 226      (N : Node_Id;
 227       D : Dominant_Info := No_Dominant);
 228    procedure Traverse_Subprogram_Or_Task_Body
 229      (N : Node_Id;
 230       D : Dominant_Info := No_Dominant);
 231
 232    procedure Traverse_Sync_Definition     (N : Node_Id);
 233    --  Traverse a protected definition or task definition
 234
 235    procedure Write_SCOs_To_ALI_File is new Put_SCOs;
 236    --  Write SCO information to the ALI file using routines in Lib.Util
 237
 238    ----------
 239    -- dsco --
 240    ----------
 241
 242    procedure dsco is
 243       procedure Dump_Entry (Index : Nat; T : SCO_Table_Entry);
 244       --  Dump a SCO table entry
 245
 246       ----------------
 247       -- Dump_Entry --
 248       ----------------
 249
 250       procedure Dump_Entry (Index : Nat; T : SCO_Table_Entry) is
 251       begin
 252          Write_Str  ("  ");
 253          Write_Int  (Index);
 254          Write_Char ('.');
 255
 256          if T.C1 /= ' ' then
 257             Write_Str  ("  C1 = '");
 258             Write_Char (T.C1);
 259             Write_Char (''');
 260          end if;
 261
 262          if T.C2 /= ' ' then
 263             Write_Str  ("  C2 = '");
 264             Write_Char (T.C2);
 265             Write_Char (''');
 266          end if;
 267
 268          if T.From /= No_Source_Location then
 269             Write_Str ("  From = ");
 270             Write_Int (Int (T.From.Line));
 271             Write_Char (':');
 272             Write_Int (Int (T.From.Col));
 273          end if;
 274
 275          if T.To /= No_Source_Location then
 276             Write_Str ("  To = ");
 277             Write_Int (Int (T.To.Line));
 278             Write_Char (':');
 279             Write_Int (Int (T.To.Col));
 280          end if;
 281
 282          if T.Last then
 283             Write_Str ("  True");
 284          else
 285             Write_Str ("  False");
 286          end if;
 287
 288          Write_Eol;
 289       end Dump_Entry;
 290
 291    --  Start of processing for dsco
 292
 293    begin
 294       --  Dump SCO unit table
 295
 296       Write_Line ("SCO Unit Table");
 297       Write_Line ("--------------");
 298
 299       for Index in 1 .. SCO_Unit_Table.Last loop
 300          declare
 301             UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
 302
 303          begin
 304             Write_Str ("  ");
 305             Write_Int (Int (Index));
 306             Write_Str ("  Dep_Num = ");
 307             Write_Int (Int (UTE.Dep_Num));
 308             Write_Str ("  From = ");
 309             Write_Int (Int (UTE.From));
 310             Write_Str ("  To = ");
 311             Write_Int (Int (UTE.To));
 312
 313             Write_Str ("  File_Name = """);
 314
 315             if UTE.File_Name /= null then
 316                Write_Str (UTE.File_Name.all);
 317             end if;
 318
 319             Write_Char ('"');
 320             Write_Eol;
 321          end;
 322       end loop;
 323
 324       --  Dump SCO Unit number table if it contains any entries
 325
 326       if SCO_Unit_Number_Table.Last >= 1 then
 327          Write_Eol;
 328          Write_Line ("SCO Unit Number Table");
 329          Write_Line ("---------------------");
 330
 331          for Index in 1 .. SCO_Unit_Number_Table.Last loop
 332             Write_Str ("  ");
 333             Write_Int (Int (Index));
 334             Write_Str (". Unit_Number = ");
 335             Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
 336             Write_Eol;
 337          end loop;
 338       end if;
 339
 340       --  Dump SCO raw-table
 341
 342       Write_Eol;
 343       Write_Line ("SCO Raw Table");
 344       Write_Line ("---------");
 345
 346       if SCO_Generation_State = Filtered then
 347          Write_Line ("Empty (free'd after second pass)");
 348       else
 349          for Index in 1 .. SCO_Raw_Table.Last loop
 350             Dump_Entry (Index, SCO_Raw_Table.Table (Index));
 351          end loop;
 352       end if;
 353
 354       --  Dump SCO table itself
 355
 356       Write_Eol;
 357       Write_Line ("SCO Filtered Table");
 358       Write_Line ("---------");
 359
 360       for Index in 1 .. SCO_Table.Last loop
 361          Dump_Entry (Index, SCO_Table.Table (Index));
 362       end loop;
 363    end dsco;
 364
 365    -----------
 366    -- Equal --
 367    -----------
 368
 369    function Equal (F1, F2 : Source_Ptr) return Boolean is
 370    begin
 371       return F1 = F2;
 372    end Equal;
 373
 374    -------
 375    -- < --
 376    -------
 377
 378    function "<" (S1, S2 : Source_Location) return Boolean is
 379    begin
 380       return S1.Line < S2.Line
 381         or else (S1.Line = S2.Line and then S1.Col < S2.Col);
 382    end "<";
 383
 384    ------------------
 385    -- Has_Decision --
 386    ------------------
 387
 388    function Has_Decision (N : Node_Id) return Boolean is
 389
 390       function Check_Node (N : Node_Id) return Traverse_Result;
 391       --  Determine if Nkind (N) indicates the presence of a decision (i.e.
 392       --  N is a logical operator, which is a decision in itself, or an
 393       --  IF-expression whose Condition attribute is a decision).
 394
 395       ----------------
 396       -- Check_Node --
 397       ----------------
 398
 399       function Check_Node (N : Node_Id) return Traverse_Result is
 400       begin
 401          --  If we are not sure this is a logical operator (AND and OR may be
 402          --  turned into logical operators with the Short_Circuit_And_Or
 403          --  pragma), assume it is. Putative decisions will be discarded if
 404          --  needed in the secord pass.
 405
 406          if Is_Logical_Operator (N) /= False
 407             or else Nkind (N) = N_If_Expression
 408          then
 409             return Abandon;
 410          else
 411             return OK;
 412          end if;
 413       end Check_Node;
 414
 415       function Traverse is new Traverse_Func (Check_Node);
 416
 417    --  Start of processing for Has_Decision
 418
 419    begin
 420       return Traverse (N) = Abandon;
 421    end Has_Decision;
 422
 423    ----------
 424    -- Hash --
 425    ----------
 426
 427    function Hash (F : Source_Ptr) return Header_Num is
 428    begin
 429       return Header_Num (Nat (F) mod 997);
 430    end Hash;
 431
 432    ----------------
 433    -- Initialize --
 434    ----------------
 435
 436    procedure Initialize is
 437    begin
 438       SCO_Unit_Number_Table.Init;
 439
 440       --  The SCO_Unit_Number_Table entry with index 0 is intentionally set
 441       --  aside to be used as temporary for sorting.
 442
 443       SCO_Unit_Number_Table.Increment_Last;
 444    end Initialize;
 445
 446    -------------------------
 447    -- Is_Logical_Operator --
 448    -------------------------
 449
 450    function Is_Logical_Operator (N : Node_Id) return Tristate is
 451    begin
 452       if Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else) then
 453          return True;
 454       elsif Nkind_In (N, N_Op_And, N_Op_Or) then
 455          return Unknown;
 456       else
 457          return False;
 458       end if;
 459    end Is_Logical_Operator;
 460
 461    -----------------------
 462    -- Process_Decisions --
 463    -----------------------
 464
 465    --  Version taking a list
 466
 467    procedure Process_Decisions
 468      (L           : List_Id;
 469       T           : Character;
 470       Pragma_Sloc : Source_Ptr)
 471    is
 472       N : Node_Id;
 473    begin
 474       if L /= No_List then
 475          N := First (L);
 476          while Present (N) loop
 477             Process_Decisions (N, T, Pragma_Sloc);
 478             Next (N);
 479          end loop;
 480       end if;
 481    end Process_Decisions;
 482
 483    --  Version taking a node
 484
 485    Current_Pragma_Sloc : Source_Ptr := No_Location;
 486    --  While processing a pragma, this is set to the sloc of the N_Pragma node
 487
 488    procedure Process_Decisions
 489      (N           : Node_Id;
 490       T           : Character;
 491       Pragma_Sloc : Source_Ptr)
 492    is
 493       Mark : Nat;
 494       --  This is used to mark the location of a decision sequence in the SCO
 495       --  table. We use it for backing out a simple decision in an expression
 496       --  context that contains only NOT operators.
 497
 498       X_Not_Decision : Boolean;
 499       --  This flag keeps track of whether a decision sequence in the SCO table
 500       --  contains only NOT operators, and is for an expression context (T=X).
 501       --  The flag will be set False if T is other than X, or if an operator
 502       --  other than NOT is in the sequence.
 503
 504       function Process_Node (N : Node_Id) return Traverse_Result;
 505       --  Processes one node in the traversal, looking for logical operators,
 506       --  and if one is found, outputs the appropriate table entries.
 507
 508       procedure Output_Decision_Operand (N : Node_Id);
 509       --  The node N is the top level logical operator of a decision, or it is
 510       --  one of the operands of a logical operator belonging to a single
 511       --  complex decision. This routine outputs the sequence of table entries
 512       --  corresponding to the node. Note that we do not process the sub-
 513       --  operands to look for further decisions, that processing is done in
 514       --  Process_Decision_Operand, because we can't get decisions mixed up in
 515       --  the global table. Call has no effect if N is Empty.
 516
 517       procedure Output_Element (N : Node_Id);
 518       --  Node N is an operand of a logical operator that is not itself a
 519       --  logical operator, or it is a simple decision. This routine outputs
 520       --  the table entry for the element, with C1 set to ' '. Last is set
 521       --  False, and an entry is made in the condition hash table.
 522
 523       procedure Output_Header (T : Character);
 524       --  Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
 525       --  PRAGMA, and 'X' for the expression case.
 526
 527       procedure Process_Decision_Operand (N : Node_Id);
 528       --  This is called on node N, the top level node of a decision, or on one
 529       --  of its operands or suboperands after generating the full output for
 530       --  the complex decision. It process the suboperands of the decision
 531       --  looking for nested decisions.
 532
 533       -----------------------------
 534       -- Output_Decision_Operand --
 535       -----------------------------
 536
 537       procedure Output_Decision_Operand (N : Node_Id) is
 538          C1, C2 : Character;
 539          --  C1 holds a character that identifies the operation while C2
 540          --  indicates whether we are sure (' ') or not ('?') this operation
 541          --  belongs to the decision. '?' entries will be filtered out in the
 542          --  second (SCO_Record_Filtered) pass.
 543
 544          L      : Node_Id;
 545          T      : Tristate;
 546
 547       begin
 548          if No (N) then
 549             return;
 550          end if;
 551
 552          T := Is_Logical_Operator (N);
 553
 554          --  Logical operator
 555
 556          if T /= False then
 557             if Nkind (N) = N_Op_Not then
 558                C1 := '!';
 559                L := Empty;
 560
 561             else
 562                L := Left_Opnd (N);
 563
 564                if Nkind_In (N, N_Op_Or, N_Or_Else) then
 565                   C1 := '|';
 566                else pragma Assert (Nkind_In (N, N_Op_And, N_And_Then));
 567                   C1 := '&';
 568                end if;
 569             end if;
 570
 571             if T = True then
 572                C2 := ' ';
 573             else
 574                C2 := '?';
 575             end if;
 576
 577             Set_Raw_Table_Entry
 578               (C1   => C1,
 579                C2   => C2,
 580                From => Sloc (N),
 581                To   => No_Location,
 582                Last => False);
 583
 584             SCO_Raw_Hash_Table.Set (Sloc (N), SCO_Raw_Table.Last);
 585
 586             Output_Decision_Operand (L);
 587             Output_Decision_Operand (Right_Opnd (N));
 588
 589          --  Not a logical operator
 590
 591          else
 592             Output_Element (N);
 593          end if;
 594       end Output_Decision_Operand;
 595
 596       --------------------
 597       -- Output_Element --
 598       --------------------
 599
 600       procedure Output_Element (N : Node_Id) is
 601          FSloc : Source_Ptr;
 602          LSloc : Source_Ptr;
 603       begin
 604          Sloc_Range (N, FSloc, LSloc);
 605          Set_Raw_Table_Entry
 606            (C1   => ' ',
 607             C2   => 'c',
 608             From => FSloc,
 609             To   => LSloc,
 610             Last => False);
 611          SCO_Raw_Hash_Table.Set (FSloc, SCO_Raw_Table.Last);
 612       end Output_Element;
 613
 614       -------------------
 615       -- Output_Header --
 616       -------------------
 617
 618       procedure Output_Header (T : Character) is
 619          Loc : Source_Ptr := No_Location;
 620          --  Node whose Sloc is used for the decision
 621
 622          Nam : Name_Id := No_Name;
 623          --  For the case of an aspect, aspect name
 624
 625       begin
 626          case T is
 627             when 'I' | 'E' | 'W' | 'a' | 'A' =>
 628
 629                --  For IF, EXIT, WHILE, or aspects, the token SLOC is that of
 630                --  the parent of the expression.
 631
 632                Loc := Sloc (Parent (N));
 633
 634                if T = 'a' or else T = 'A' then
 635                   Nam := Chars (Identifier (Parent (N)));
 636                end if;
 637
 638             when 'G' | 'P' =>
 639
 640                --  For entry guard, the token sloc is from the N_Entry_Body.
 641                --  For PRAGMA, we must get the location from the pragma node.
 642                --  Argument N is the pragma argument, and we have to go up
 643                --  two levels (through the pragma argument association) to
 644                --  get to the pragma node itself. For the guard on a select
 645                --  alternative, we do not have access to the token location for
 646                --  the WHEN, so we use the first sloc of the condition itself
 647                --  (note: we use First_Sloc, not Sloc, because this is what is
 648                --  referenced by dominance markers).
 649
 650                --  Doesn't this requirement of using First_Sloc need to be
 651                --  documented in the spec ???
 652
 653                if Nkind_In (Parent (N), N_Accept_Alternative,
 654                                         N_Delay_Alternative,
 655                                         N_Terminate_Alternative)
 656                then
 657                   Loc := First_Sloc (N);
 658                else
 659                   Loc := Sloc (Parent (Parent (N)));
 660                end if;
 661
 662             when 'X' =>
 663
 664                --  For an expression, no Sloc
 665
 666                null;
 667
 668             --  No other possibilities
 669
 670             when others =>
 671                raise Program_Error;
 672          end case;
 673
 674          Set_Raw_Table_Entry
 675            (C1                 => T,
 676             C2                 => ' ',
 677             From               => Loc,
 678             To                 => No_Location,
 679             Last               => False,
 680             Pragma_Sloc        => Pragma_Sloc,
 681             Pragma_Aspect_Name => Nam);
 682
 683          --  For an aspect specification, which will be rewritten into a
 684          --  pragma, enter a hash table entry now.
 685
 686          if T = 'a' then
 687             SCO_Raw_Hash_Table.Set (Loc, SCO_Raw_Table.Last);
 688          end if;
 689       end Output_Header;
 690
 691       ------------------------------
 692       -- Process_Decision_Operand --
 693       ------------------------------
 694
 695       procedure Process_Decision_Operand (N : Node_Id) is
 696       begin
 697          if Is_Logical_Operator (N) /= False then
 698             if Nkind (N) /= N_Op_Not then
 699                Process_Decision_Operand (Left_Opnd (N));
 700                X_Not_Decision := False;
 701             end if;
 702
 703             Process_Decision_Operand (Right_Opnd (N));
 704
 705          else
 706             Process_Decisions (N, 'X', Pragma_Sloc);
 707          end if;
 708       end Process_Decision_Operand;
 709
 710       ------------------
 711       -- Process_Node --
 712       ------------------
 713
 714       function Process_Node (N : Node_Id) return Traverse_Result is
 715       begin
 716          case Nkind (N) is
 717
 718             --  Logical operators, output table entries and then process
 719             --  operands recursively to deal with nested conditions.
 720
 721             when N_And_Then | N_Or_Else | N_Op_Not | N_Op_And | N_Op_Or =>
 722                declare
 723                   T : Character;
 724
 725                begin
 726                   --  If outer level, then type comes from call, otherwise it
 727                   --  is more deeply nested and counts as X for expression.
 728
 729                   if N = Process_Decisions.N then
 730                      T := Process_Decisions.T;
 731                   else
 732                      T := 'X';
 733                   end if;
 734
 735                   --  Output header for sequence
 736
 737                   X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
 738                   Mark := SCO_Raw_Table.Last;
 739                   Output_Header (T);
 740
 741                   --  Output the decision
 742
 743                   Output_Decision_Operand (N);
 744
 745                   --  If the decision was in an expression context (T = 'X')
 746                   --  and contained only NOT operators, then we don't output
 747                   --  it, so delete it.
 748
 749                   if X_Not_Decision then
 750                      SCO_Raw_Table.Set_Last (Mark);
 751
 752                   --  Otherwise, set Last in last table entry to mark end
 753
 754                   else
 755                      SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True;
 756                   end if;
 757
 758                   --  Process any embedded decisions
 759
 760                   Process_Decision_Operand (N);
 761                   return Skip;
 762                end;
 763
 764             --  Case expression
 765
 766             --  Really hard to believe this is correct given the special
 767             --  handling for if expressions below ???
 768
 769             when N_Case_Expression =>
 770                return OK; -- ???
 771
 772             --  If expression, processed like an if statement
 773
 774             when N_If_Expression =>
 775                declare
 776                   Cond : constant Node_Id := First (Expressions (N));
 777                   Thnx : constant Node_Id := Next (Cond);
 778                   Elsx : constant Node_Id := Next (Thnx);
 779                begin
 780                   Process_Decisions (Cond, 'I', Pragma_Sloc);
 781                   Process_Decisions (Thnx, 'X', Pragma_Sloc);
 782                   Process_Decisions (Elsx, 'X', Pragma_Sloc);
 783                   return Skip;
 784                end;
 785
 786             --  All other cases, continue scan
 787
 788             when others =>
 789                return OK;
 790
 791          end case;
 792       end Process_Node;
 793
 794       procedure Traverse is new Traverse_Proc (Process_Node);
 795
 796    --  Start of processing for Process_Decisions
 797
 798    begin
 799       if No (N) then
 800          return;
 801       end if;
 802
 803       --  See if we have simple decision at outer level and if so then
 804       --  generate the decision entry for this simple decision. A simple
 805       --  decision is a boolean expression (which is not a logical operator
 806       --  or short circuit form) appearing as the operand of an IF, WHILE,
 807       --  EXIT WHEN, or special PRAGMA construct.
 808
 809       if T /= 'X' and then Is_Logical_Operator (N) = False then
 810          Output_Header (T);
 811          Output_Element (N);
 812
 813          --  Change Last in last table entry to True to mark end of
 814          --  sequence, which is this case is only one element long.
 815
 816          SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True;
 817       end if;
 818
 819       Traverse (N);
 820    end Process_Decisions;
 821
 822    -----------
 823    -- pscos --
 824    -----------
 825
 826    procedure pscos is
 827
 828       procedure Write_Info_Char (C : Character) renames Write_Char;
 829       --  Write one character;
 830
 831       procedure Write_Info_Initiate (Key : Character) renames Write_Char;
 832       --  Start new one and write one character;
 833
 834       procedure Write_Info_Nat (N : Nat);
 835       --  Write value of N
 836
 837       procedure Write_Info_Terminate renames Write_Eol;
 838       --  Terminate current line
 839
 840       --------------------
 841       -- Write_Info_Nat --
 842       --------------------
 843
 844       procedure Write_Info_Nat (N : Nat) is
 845       begin
 846          Write_Int (N);
 847       end Write_Info_Nat;
 848
 849       procedure Debug_Put_SCOs is new Put_SCOs;
 850
 851    --  Start of processing for pscos
 852
 853    begin
 854       Debug_Put_SCOs;
 855    end pscos;
 856
 857    ---------------------
 858    -- Record_Instance --
 859    ---------------------
 860
 861    procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is
 862       Inst_Src  : constant Source_File_Index :=
 863                     Get_Source_File_Index (Inst_Sloc);
 864    begin
 865       SCO_Instance_Table.Append
 866         ((Inst_Dep_Num       => Dependency_Num (Unit (Inst_Src)),
 867           Inst_Loc           => To_Source_Location (Inst_Sloc),
 868           Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src))));
 869       pragma Assert
 870         (SCO_Instance_Table.Last = SCO_Instance_Index (Id));
 871    end Record_Instance;
 872
 873    ----------------
 874    -- SCO_Output --
 875    ----------------
 876
 877    procedure SCO_Output is
 878       procedure Populate_SCO_Instance_Table is
 879         new Sinput.Iterate_On_Instances (Record_Instance);
 880    begin
 881       pragma Assert (SCO_Generation_State = Filtered);
 882
 883       if Debug_Flag_Dot_OO then
 884          dsco;
 885       end if;
 886
 887       Populate_SCO_Instance_Table;
 888
 889       --  Sort the unit tables based on dependency numbers
 890
 891       Unit_Table_Sort : declare
 892
 893          function Lt (Op1, Op2 : Natural) return Boolean;
 894          --  Comparison routine for sort call
 895
 896          procedure Move (From : Natural; To : Natural);
 897          --  Move routine for sort call
 898
 899          --------
 900          -- Lt --
 901          --------
 902
 903          function Lt (Op1, Op2 : Natural) return Boolean is
 904          begin
 905             return
 906               Dependency_Num
 907                 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
 908                      <
 909               Dependency_Num
 910                 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
 911          end Lt;
 912
 913          ----------
 914          -- Move --
 915          ----------
 916
 917          procedure Move (From : Natural; To : Natural) is
 918          begin
 919             SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
 920               SCO_Unit_Table.Table (SCO_Unit_Index (From));
 921             SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
 922               SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
 923          end Move;
 924
 925          package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
 926
 927       --  Start of processing for Unit_Table_Sort
 928
 929       begin
 930          Sorting.Sort (Integer (SCO_Unit_Table.Last));
 931       end Unit_Table_Sort;
 932
 933       --  Loop through entries in the unit table to set file name and
 934       --  dependency number entries.
 935
 936       for J in 1 .. SCO_Unit_Table.Last loop
 937          declare
 938             U   : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
 939             UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
 940          begin
 941             Get_Name_String (Reference_Name (Source_Index (U)));
 942             UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
 943             UTE.Dep_Num := Dependency_Num (U);
 944          end;
 945       end loop;
 946
 947       --  Now the tables are all setup for output to the ALI file
 948
 949       Write_SCOs_To_ALI_File;
 950    end SCO_Output;
 951
 952    -------------------------
 953    -- SCO_Pragma_Disabled --
 954    -------------------------
 955
 956    function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
 957       Index : Nat;
 958
 959    begin
 960       if Loc = No_Location then
 961          return False;
 962       end if;
 963
 964       Index := SCO_Raw_Hash_Table.Get (Loc);
 965
 966       --  The test here for zero is to deal with possible previous errors, and
 967       --  for the case of pragma statement SCOs, for which we always set the
 968       --  Pragma_Sloc even if the particular pragma cannot be specifically
 969       --  disabled.
 970
 971       if Index /= 0 then
 972          declare
 973             T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
 974
 975          begin
 976             case T.C1 is
 977                when 'S' =>
 978                   --  Pragma statement
 979
 980                   return T.C2 = 'p';
 981
 982                when 'A' =>
 983                   --  Aspect decision (enabled)
 984
 985                   return False;
 986
 987                when 'a' =>
 988                   --  Aspect decision (not enabled)
 989
 990                   return True;
 991
 992                when ASCII.NUL =>
 993                   --  Nullified disabled SCO
 994
 995                   return True;
 996
 997                when others =>
 998                   raise Program_Error;
 999             end case;
1000          end;
1001
1002       else
1003          return False;
1004       end if;
1005    end SCO_Pragma_Disabled;
1006
1007    --------------------
1008    -- SCO_Record_Raw --
1009    --------------------
1010
1011    procedure SCO_Record_Raw (U : Unit_Number_Type) is
1012       Lu   : Node_Id;
1013       From : Nat;
1014
1015       procedure Traverse_Aux_Decls (N : Node_Id);
1016       --  Traverse the Aux_Decls_Node of compilation unit N
1017
1018       ------------------------
1019       -- Traverse_Aux_Decls --
1020       ------------------------
1021
1022       procedure Traverse_Aux_Decls (N : Node_Id) is
1023          ADN : constant Node_Id := Aux_Decls_Node (N);
1024       begin
1025          Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
1026          Traverse_Declarations_Or_Statements (Pragmas_After  (ADN));
1027
1028          --  Declarations and Actions do not correspond to source constructs,
1029          --  they contain only nodes from expansion, so at this point they
1030          --  should still be empty:
1031
1032          pragma Assert (No (Declarations (ADN)));
1033          pragma Assert (No (Actions (ADN)));
1034       end Traverse_Aux_Decls;
1035
1036    --  Start of processing for SCO_Record_Raw
1037
1038    begin
1039       --  It is legitimate to run this pass multiple times (once per unit) so
1040       --  run it even if it was already run before.
1041
1042       pragma Assert (SCO_Generation_State in None .. Raw);
1043       SCO_Generation_State := Raw;
1044
1045       --  Ignore call if not generating code and generating SCO's
1046
1047       if not (Generate_SCO and then Operating_Mode = Generate_Code) then
1048          return;
1049       end if;
1050
1051       --  Ignore call if this unit already recorded
1052
1053       for J in 1 .. SCO_Unit_Number_Table.Last loop
1054          if U = SCO_Unit_Number_Table.Table (J) then
1055             return;
1056          end if;
1057       end loop;
1058
1059       --  Otherwise record starting entry
1060
1061       From := SCO_Raw_Table.Last + 1;
1062
1063       --  Get Unit (checking case of subunit)
1064
1065       Lu := Unit (Cunit (U));
1066
1067       if Nkind (Lu) = N_Subunit then
1068          Lu := Proper_Body (Lu);
1069       end if;
1070
1071       --  Traverse the unit
1072
1073       Traverse_Aux_Decls (Cunit (U));
1074
1075       case Nkind (Lu) is
1076          when
1077            N_Package_Declaration         |
1078            N_Package_Body                |
1079            N_Subprogram_Declaration      |
1080            N_Subprogram_Body             |
1081            N_Generic_Package_Declaration |
1082            N_Protected_Body              |
1083            N_Task_Body                   |
1084            N_Generic_Instantiation       =>
1085
1086             Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
1087
1088          when others =>
1089
1090             --  All other cases of compilation units (e.g. renamings), generate
1091             --  no SCO information.
1092
1093             null;
1094       end case;
1095
1096       --  Make entry for new unit in unit tables, we will fill in the file
1097       --  name and dependency numbers later.
1098
1099       SCO_Unit_Table.Append (
1100         (Dep_Num    => 0,
1101          File_Name  => null,
1102          File_Index => Get_Source_File_Index (Sloc (Lu)),
1103          From       => From,
1104          To         => SCO_Raw_Table.Last));
1105
1106       SCO_Unit_Number_Table.Append (U);
1107    end SCO_Record_Raw;
1108
1109    -----------------------
1110    -- Set_SCO_Condition --
1111    -----------------------
1112
1113    procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
1114
1115       --  SCO annotations are not processed after the filtering pass
1116
1117       pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1118
1119       Orig  : constant Node_Id := Original_Node (Cond);
1120       Index : Nat;
1121       Start : Source_Ptr;
1122       Dummy : Source_Ptr;
1123
1124       Constant_Condition_Code : constant array (Boolean) of Character :=
1125                                   (False => 'f', True => 't');
1126    begin
1127       Sloc_Range (Orig, Start, Dummy);
1128       Index := SCO_Raw_Hash_Table.Get (Start);
1129
1130       --  Index can be zero for boolean expressions that do not have SCOs
1131       --  (simple decisions outside of a control flow structure), or in case
1132       --  of a previous error.
1133
1134       if Index = 0 then
1135          return;
1136
1137       else
1138          pragma Assert (SCO_Raw_Table.Table (Index).C1 = ' ');
1139          SCO_Raw_Table.Table (Index).C2 := Constant_Condition_Code (Val);
1140       end if;
1141    end Set_SCO_Condition;
1142
1143    ------------------------------
1144    -- Set_SCO_Logical_Operator --
1145    ------------------------------
1146
1147    procedure Set_SCO_Logical_Operator (Op : Node_Id) is
1148
1149       --  SCO annotations are not processed after the filtering pass
1150
1151       pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1152
1153       Orig      : constant Node_Id := Original_Node (Op);
1154       Orig_Sloc : constant Source_Ptr := Sloc (Orig);
1155       Index     : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc);
1156
1157    begin
1158       --  All (putative) logical operators are supposed to have their own entry
1159       --  in the SCOs table. However, the semantic analysis may invoke this
1160       --  subprogram with nodes that are out of the SCO generation scope.
1161
1162       if Index /= 0 then
1163          SCO_Raw_Table.Table (Index).C2 := ' ';
1164       end if;
1165    end Set_SCO_Logical_Operator;
1166
1167    ----------------------------
1168    -- Set_SCO_Pragma_Enabled --
1169    ----------------------------
1170
1171    procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
1172
1173       --  SCO annotations are not processed after the filtering pass
1174
1175       pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1176
1177       Index : Nat;
1178
1179    begin
1180       --  Nothing to do if not generating SCO, or if we're not processing the
1181       --  original source occurrence of the pragma.
1182
1183       if not (Generate_SCO
1184                and then In_Extended_Main_Source_Unit (Loc)
1185                and then not (In_Instance or In_Inlined_Body))
1186       then
1187          return;
1188       end if;
1189
1190       --  Note: the reason we use the Sloc value as the key is that in the
1191       --  generic case, the call to this procedure is made on a copy of the
1192       --  original node, so we can't use the Node_Id value.
1193
1194       Index := SCO_Raw_Hash_Table.Get (Loc);
1195
1196       --  A zero index here indicates that semantic analysis found an
1197       --  activated pragma at Loc which does not have a corresponding pragma
1198       --  or aspect at the syntax level. This may occur in legitimate cases
1199       --  because of expanded code (such are Pre/Post conditions generated for
1200       --  formal parameter validity checks), or as a consequence of a previous
1201       --  error.
1202
1203       if Index = 0 then
1204          return;
1205
1206       else
1207          declare
1208             T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
1209
1210          begin
1211             --  Note: may be called multiple times for the same sloc, so
1212             --  account for the fact that the entry may already have been
1213             --  marked enabled.
1214
1215             case T.C1 is
1216                --  Aspect (decision SCO)
1217
1218                when 'a' =>
1219                   T.C1 := 'A';
1220
1221                when 'A' =>
1222                   null;
1223
1224                --  Pragma (statement SCO)
1225
1226                when 'S' =>
1227                   pragma Assert (T.C2 = 'p' or else T.C2 = 'P');
1228                   T.C2 := 'P';
1229
1230                when others =>
1231                   raise Program_Error;
1232             end case;
1233          end;
1234       end if;
1235    end Set_SCO_Pragma_Enabled;
1236
1237    -------------------------
1238    -- Set_Raw_Table_Entry --
1239    -------------------------
1240
1241    procedure Set_Raw_Table_Entry
1242      (C1                 : Character;
1243       C2                 : Character;
1244       From               : Source_Ptr;
1245       To                 : Source_Ptr;
1246       Last               : Boolean;
1247       Pragma_Sloc        : Source_Ptr := No_Location;
1248       Pragma_Aspect_Name : Name_Id    := No_Name)
1249    is
1250       pragma Assert (SCO_Generation_State = Raw);
1251    begin
1252       SCO_Raw_Table.Append
1253         ((C1                 => C1,
1254           C2                 => C2,
1255           From               => To_Source_Location (From),
1256           To                 => To_Source_Location (To),
1257           Last               => Last,
1258           Pragma_Sloc        => Pragma_Sloc,
1259           Pragma_Aspect_Name => Pragma_Aspect_Name));
1260    end Set_Raw_Table_Entry;
1261
1262    ------------------------
1263    -- To_Source_Location --
1264    ------------------------
1265
1266    function To_Source_Location (S : Source_Ptr) return Source_Location is
1267    begin
1268       if S = No_Location then
1269          return No_Source_Location;
1270       else
1271          return
1272            (Line => Get_Logical_Line_Number (S),
1273             Col  => Get_Column_Number (S));
1274       end if;
1275    end To_Source_Location;
1276
1277    -----------------------------------------
1278    -- Traverse_Declarations_Or_Statements --
1279    -----------------------------------------
1280
1281    --  Tables used by Traverse_Declarations_Or_Statements for temporarily
1282    --  holding statement and decision entries. These are declared globally
1283    --  since they are shared by recursive calls to this procedure.
1284
1285    type SC_Entry is record
1286       N    : Node_Id;
1287       From : Source_Ptr;
1288       To   : Source_Ptr;
1289       Typ  : Character;
1290    end record;
1291    --  Used to store a single entry in the following table, From:To represents
1292    --  the range of entries in the CS line entry, and typ is the type, with
1293    --  space meaning that no type letter will accompany the entry.
1294
1295    package SC is new Table.Table (
1296      Table_Component_Type => SC_Entry,
1297      Table_Index_Type     => Nat,
1298      Table_Low_Bound      => 1,
1299      Table_Initial        => 1000,
1300      Table_Increment      => 200,
1301      Table_Name           => "SCO_SC");
1302       --  Used to store statement components for a CS entry to be output
1303       --  as a result of the call to this procedure. SC.Last is the last
1304       --  entry stored, so the current statement sequence is represented
1305       --  by SC_Array (SC_First .. SC.Last), where SC_First is saved on
1306       --  entry to each recursive call to the routine.
1307       --
1308       --  Extend_Statement_Sequence adds an entry to this array, and then
1309       --  Set_Statement_Entry clears the entries starting with SC_First,
1310       --  copying these entries to the main SCO output table. The reason that
1311       --  we do the temporary caching of results in this array is that we want
1312       --  the SCO table entries for a given CS line to be contiguous, and the
1313       --  processing may output intermediate entries such as decision entries.
1314
1315    type SD_Entry is record
1316       Nod : Node_Id;
1317       Lst : List_Id;
1318       Typ : Character;
1319       Plo : Source_Ptr;
1320    end record;
1321    --  Used to store a single entry in the following table. Nod is the node to
1322    --  be searched for decisions for the case of Process_Decisions_Defer with a
1323    --  node argument (with Lst set to No_List. Lst is the list to be searched
1324    --  for decisions for the case of Process_Decisions_Defer with a List
1325    --  argument (in which case Nod is set to Empty). Plo is the sloc of the
1326    --  enclosing pragma, if any.
1327
1328    package SD is new Table.Table (
1329      Table_Component_Type => SD_Entry,
1330      Table_Index_Type     => Nat,
1331      Table_Low_Bound      => 1,
1332      Table_Initial        => 1000,
1333      Table_Increment      => 200,
1334      Table_Name           => "SCO_SD");
1335    --  Used to store possible decision information. Instead of calling the
1336    --  Process_Decisions procedures directly, we call Process_Decisions_Defer,
1337    --  which simply stores the arguments in this table. Then when we clear
1338    --  out a statement sequence using Set_Statement_Entry, after generating
1339    --  the CS lines for the statements, the entries in this table result in
1340    --  calls to Process_Decision. The reason for doing things this way is to
1341    --  ensure that decisions are output after the CS line for the statements
1342    --  in which the decisions occur.
1343
1344    procedure Traverse_Declarations_Or_Statements
1345      (L : List_Id;
1346       D : Dominant_Info := No_Dominant;
1347       P : Node_Id       := Empty)
1348    is
1349       Discard_Dom : Dominant_Info;
1350       pragma Warnings (Off, Discard_Dom);
1351    begin
1352       Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P);
1353    end Traverse_Declarations_Or_Statements;
1354
1355    function Traverse_Declarations_Or_Statements
1356      (L : List_Id;
1357       D : Dominant_Info := No_Dominant;
1358       P : Node_Id       := Empty) return Dominant_Info
1359    is
1360       Current_Dominant : Dominant_Info := D;
1361       --  Dominance information for the current basic block
1362
1363       Current_Test : Node_Id;
1364       --  Conditional node (N_If_Statement or N_Elsiif being processed
1365
1366       N : Node_Id;
1367
1368       SC_First : constant Nat := SC.Last + 1;
1369       SD_First : constant Nat := SD.Last + 1;
1370       --  Record first entries used in SC/SD at this recursive level
1371
1372       procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
1373       --  Extend the current statement sequence to encompass the node N. Typ
1374       --  is the letter that identifies the type of statement/declaration that
1375       --  is being added to the sequence.
1376
1377       procedure Set_Statement_Entry;
1378       --  Output CS entries for all statements saved in table SC, and end the
1379       --  current CS sequence. Then output entries for all decisions nested in
1380       --  these statements, which have been deferred so far.
1381
1382       procedure Process_Decisions_Defer (N : Node_Id; T : Character);
1383       pragma Inline (Process_Decisions_Defer);
1384       --  This routine is logically the same as Process_Decisions, except that
1385       --  the arguments are saved in the SD table for later processing when
1386       --  Set_Statement_Entry is called, which goes through the saved entries
1387       --  making the corresponding calls to Process_Decision.
1388
1389       procedure Process_Decisions_Defer (L : List_Id; T : Character);
1390       pragma Inline (Process_Decisions_Defer);
1391       --  Same case for list arguments, deferred call to Process_Decisions
1392
1393       procedure Traverse_One (N : Node_Id);
1394       --  Traverse one declaration or statement
1395
1396       procedure Traverse_Aspects (N : Node_Id);
1397       --  Helper for Traverse_One: traverse N's aspect specifications
1398
1399       -------------------------
1400       -- Set_Statement_Entry --
1401       -------------------------
1402
1403       procedure Set_Statement_Entry is
1404          SC_Last : constant Int := SC.Last;
1405          SD_Last : constant Int := SD.Last;
1406
1407       begin
1408          --  Output statement entries from saved entries in SC table
1409
1410          for J in SC_First .. SC_Last loop
1411             if J = SC_First then
1412
1413                if Current_Dominant /= No_Dominant then
1414                   declare
1415                      From, To : Source_Ptr;
1416                   begin
1417                      Sloc_Range (Current_Dominant.N, From, To);
1418                      if Current_Dominant.K /= 'E' then
1419                         To := No_Location;
1420                      end if;
1421                      Set_Raw_Table_Entry
1422                        (C1                 => '>',
1423                         C2                 => Current_Dominant.K,
1424                         From               => From,
1425                         To                 => To,
1426                         Last               => False,
1427                         Pragma_Sloc        => No_Location,
1428                         Pragma_Aspect_Name => No_Name);
1429                   end;
1430                end if;
1431             end if;
1432
1433             declare
1434                SCE                : SC_Entry renames SC.Table (J);
1435                Pragma_Sloc        : Source_Ptr := No_Location;
1436                Pragma_Aspect_Name : Name_Id    := No_Name;
1437             begin
1438                --  For the case of a statement SCO for a pragma controlled by
1439                --  Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
1440                --  those of any nested decision) is emitted only if the pragma
1441                --  is enabled.
1442
1443                if SCE.Typ = 'p' then
1444                   Pragma_Sloc := SCE.From;
1445                   SCO_Raw_Hash_Table.Set
1446                     (Pragma_Sloc, SCO_Raw_Table.Last + 1);
1447                   Pragma_Aspect_Name := Pragma_Name (SCE.N);
1448                   pragma Assert (Pragma_Aspect_Name /= No_Name);
1449
1450                elsif SCE.Typ = 'P' then
1451                   Pragma_Aspect_Name := Pragma_Name (SCE.N);
1452                   pragma Assert (Pragma_Aspect_Name /= No_Name);
1453                end if;
1454
1455                Set_Raw_Table_Entry
1456                  (C1                 => 'S',
1457                   C2                 => SCE.Typ,
1458                   From               => SCE.From,
1459                   To                 => SCE.To,
1460                   Last               => (J = SC_Last),
1461                   Pragma_Sloc        => Pragma_Sloc,
1462                   Pragma_Aspect_Name => Pragma_Aspect_Name);
1463             end;
1464          end loop;
1465
1466          --  Last statement of basic block, if present, becomes new current
1467          --  dominant.
1468
1469          if SC_Last >= SC_First then
1470             Current_Dominant := ('S', SC.Table (SC_Last).N);
1471          end if;
1472
1473          --  Clear out used section of SC table
1474
1475          SC.Set_Last (SC_First - 1);
1476
1477          --  Output any embedded decisions
1478
1479          for J in SD_First .. SD_Last loop
1480             declare
1481                SDE : SD_Entry renames SD.Table (J);
1482             begin
1483                if Present (SDE.Nod) then
1484                   Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
1485                else
1486                   Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
1487                end if;
1488             end;
1489          end loop;
1490
1491          --  Clear out used section of SD table
1492
1493          SD.Set_Last (SD_First - 1);
1494       end Set_Statement_Entry;
1495
1496       -------------------------------
1497       -- Extend_Statement_Sequence --
1498       -------------------------------
1499
1500       procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1501          F       : Source_Ptr;
1502          T       : Source_Ptr;
1503          Dummy   : Source_Ptr;
1504          To_Node : Node_Id := Empty;
1505
1506       begin
1507          Sloc_Range (N, F, T);
1508
1509          case Nkind (N) is
1510             when N_Accept_Statement =>
1511                if Present (Parameter_Specifications (N)) then
1512                   To_Node := Last (Parameter_Specifications (N));
1513                elsif Present (Entry_Index (N)) then
1514                   To_Node := Entry_Index (N);
1515                end if;
1516
1517             when N_Case_Statement =>
1518                To_Node := Expression (N);
1519
1520             when N_If_Statement | N_Elsif_Part =>
1521                To_Node := Condition (N);
1522
1523             when N_Extended_Return_Statement =>
1524                To_Node := Last (Return_Object_Declarations (N));
1525
1526             when N_Loop_Statement =>
1527                To_Node := Iteration_Scheme (N);
1528
1529             when N_Selective_Accept             |
1530                  N_Timed_Entry_Call             |
1531                  N_Conditional_Entry_Call       |
1532                  N_Asynchronous_Select          |
1533                  N_Single_Protected_Declaration |
1534                  N_Single_Task_Declaration      =>
1535                T := F;
1536
1537             when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
1538                if Has_Aspects (N) then
1539                   To_Node := Last (Aspect_Specifications (N));
1540
1541                elsif Present (Discriminant_Specifications (N)) then
1542                   To_Node := Last (Discriminant_Specifications (N));
1543
1544                else
1545                   To_Node := Defining_Identifier (N);
1546                end if;
1547
1548             when others =>
1549                null;
1550
1551          end case;
1552
1553          if Present (To_Node) then
1554             Sloc_Range (To_Node, Dummy, T);
1555          end if;
1556
1557          SC.Append ((N, F, T, Typ));
1558       end Extend_Statement_Sequence;
1559
1560       -----------------------------
1561       -- Process_Decisions_Defer --
1562       -----------------------------
1563
1564       procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1565       begin
1566          SD.Append ((N, No_List, T, Current_Pragma_Sloc));
1567       end Process_Decisions_Defer;
1568
1569       procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1570       begin
1571          SD.Append ((Empty, L, T, Current_Pragma_Sloc));
1572       end Process_Decisions_Defer;
1573
1574       ----------------------
1575       -- Traverse_Aspects --
1576       ----------------------
1577
1578       procedure Traverse_Aspects (N : Node_Id) is
1579          AN : Node_Id;
1580          AE : Node_Id;
1581          C1 : Character;
1582
1583       begin
1584          AN := First (Aspect_Specifications (N));
1585          while Present (AN) loop
1586             AE := Expression (AN);
1587
1588             --  SCOs are generated before semantic analysis/expansion:
1589             --  PPCs are not split yet.
1590
1591             pragma Assert (not Split_PPC (AN));
1592
1593             C1 := ASCII.NUL;
1594
1595             case Get_Aspect_Id (AN) is
1596
1597                --  Aspects rewritten into pragmas controlled by a Check_Policy:
1598                --  Current_Pragma_Sloc must be set to the sloc of the aspect
1599                --  specification. The corresponding pragma will have the same
1600                --  sloc.
1601
1602                when Aspect_Pre           |
1603                     Aspect_Precondition  |
1604                     Aspect_Post          |
1605                     Aspect_Postcondition |
1606                     Aspect_Invariant     =>
1607
1608                   C1 := 'a';
1609
1610                --  Aspects whose checks are generated in client units,
1611                --  regardless of whether or not the check is activated in the
1612                --  unit which contains the declaration: create decision as
1613                --  unconditionally enabled aspect (but still make a pragma
1614                --  entry since Set_SCO_Pragma_Enabled will be called when
1615                --  analyzing actual checks, possibly in other units).
1616
1617                --  Pre/post can have checks in client units too because of
1618                --  inheritance, so should they be moved here???
1619
1620                when Aspect_Predicate         |
1621                     Aspect_Static_Predicate  |
1622                     Aspect_Dynamic_Predicate |
1623                     Aspect_Type_Invariant    =>
1624
1625                   C1 := 'A';
1626
1627                --  Other aspects: just process any decision nested in the
1628                --  aspect expression.
1629
1630                when others =>
1631
1632                   if Has_Decision (AE) then
1633                      C1 := 'X';
1634                   end if;
1635
1636             end case;
1637
1638             if C1 /= ASCII.NUL then
1639                pragma Assert (Current_Pragma_Sloc = No_Location);
1640
1641                if C1 = 'a' or else C1 = 'A' then
1642                   Current_Pragma_Sloc := Sloc (AN);
1643                end if;
1644
1645                Process_Decisions_Defer (AE, C1);
1646
1647                Current_Pragma_Sloc := No_Location;
1648             end if;
1649
1650             Next (AN);
1651          end loop;
1652       end Traverse_Aspects;
1653
1654       ------------------
1655       -- Traverse_One --
1656       ------------------
1657
1658       procedure Traverse_One (N : Node_Id) is
1659       begin
1660          --  Initialize or extend current statement sequence. Note that for
1661          --  special cases such as IF and Case statements we will modify
1662          --  the range to exclude internal statements that should not be
1663          --  counted as part of the current statement sequence.
1664
1665          case Nkind (N) is
1666
1667             --  Package declaration
1668
1669             when N_Package_Declaration =>
1670                Set_Statement_Entry;
1671                Traverse_Package_Declaration (N, Current_Dominant);
1672
1673             --  Generic package declaration
1674
1675             when N_Generic_Package_Declaration =>
1676                Set_Statement_Entry;
1677                Traverse_Generic_Package_Declaration (N);
1678
1679             --  Package body
1680
1681             when N_Package_Body =>
1682                Set_Statement_Entry;
1683                Traverse_Package_Body (N);
1684
1685             --  Subprogram declaration or subprogram body stub
1686
1687             when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
1688                Process_Decisions_Defer
1689                  (Parameter_Specifications (Specification (N)), 'X');
1690
1691             --  Entry declaration
1692
1693             when N_Entry_Declaration =>
1694                Process_Decisions_Defer (Parameter_Specifications (N), 'X');
1695
1696             --  Generic subprogram declaration
1697
1698             when N_Generic_Subprogram_Declaration =>
1699                Process_Decisions_Defer
1700                  (Generic_Formal_Declarations (N), 'X');
1701                Process_Decisions_Defer
1702                  (Parameter_Specifications (Specification (N)), 'X');
1703
1704             --  Task or subprogram body
1705
1706             when N_Task_Body | N_Subprogram_Body =>
1707                Set_Statement_Entry;
1708                Traverse_Subprogram_Or_Task_Body (N);
1709
1710             --  Entry body
1711
1712             when N_Entry_Body =>
1713                declare
1714                   Cond : constant Node_Id :=
1715                            Condition (Entry_Body_Formal_Part (N));
1716
1717                   Inner_Dominant : Dominant_Info := No_Dominant;
1718
1719                begin
1720                   Set_Statement_Entry;
1721
1722                   if Present (Cond) then
1723                      Process_Decisions_Defer (Cond, 'G');
1724
1725                      --  For an entry body with a barrier, the entry body
1726                      --  is dominanted by a True evaluation of the barrier.
1727
1728                      Inner_Dominant := ('T', N);
1729                   end if;
1730
1731                   Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
1732                end;
1733
1734             --  Protected body
1735
1736             when N_Protected_Body =>
1737                Set_Statement_Entry;
1738                Traverse_Declarations_Or_Statements (Declarations (N));
1739
1740             --  Exit statement, which is an exit statement in the SCO sense,
1741             --  so it is included in the current statement sequence, but
1742             --  then it terminates this sequence. We also have to process
1743             --  any decisions in the exit statement expression.
1744
1745             when N_Exit_Statement =>
1746                Extend_Statement_Sequence (N, 'E');
1747                Process_Decisions_Defer (Condition (N), 'E');
1748                Set_Statement_Entry;
1749
1750                --  If condition is present, then following statement is
1751                --  only executed if the condition evaluates to False.
1752
1753                if Present (Condition (N)) then
1754                   Current_Dominant := ('F', N);
1755                else
1756                   Current_Dominant := No_Dominant;
1757                end if;
1758
1759             --  Label, which breaks the current statement sequence, but the
1760             --  label itself is not included in the next statement sequence,
1761             --  since it generates no code.
1762
1763             when N_Label =>
1764                Set_Statement_Entry;
1765                Current_Dominant := No_Dominant;
1766
1767             --  Block statement, which breaks the current statement sequence
1768
1769             when N_Block_Statement =>
1770                Set_Statement_Entry;
1771
1772                --  The first statement in the handled sequence of statements
1773                --  is dominated by the elaboration of the last declaration.
1774
1775                Current_Dominant := Traverse_Declarations_Or_Statements
1776                                      (L => Declarations (N),
1777                                       D => Current_Dominant);
1778
1779                Traverse_Handled_Statement_Sequence
1780                  (N => Handled_Statement_Sequence (N),
1781                   D => Current_Dominant);
1782
1783             --  If statement, which breaks the current statement sequence,
1784             --  but we include the condition in the current sequence.
1785
1786             when N_If_Statement =>
1787                Current_Test := N;
1788                Extend_Statement_Sequence (N, 'I');
1789                Process_Decisions_Defer (Condition (N), 'I');
1790                Set_Statement_Entry;
1791
1792                --  Now we traverse the statements in the THEN part
1793
1794                Traverse_Declarations_Or_Statements
1795                  (L => Then_Statements (N),
1796                   D => ('T', N));
1797
1798                --  Loop through ELSIF parts if present
1799
1800                if Present (Elsif_Parts (N)) then
1801                   declare
1802                      Saved_Dominant : constant Dominant_Info :=
1803                                         Current_Dominant;
1804
1805                      Elif : Node_Id := First (Elsif_Parts (N));
1806
1807                   begin
1808                      while Present (Elif) loop
1809
1810                         --  An Elsif is executed only if the previous test
1811                         --  got a FALSE outcome.
1812
1813                         Current_Dominant := ('F', Current_Test);
1814
1815                         --  Now update current test information
1816
1817                         Current_Test := Elif;
1818
1819                         --  We generate a statement sequence for the
1820                         --  construct "ELSIF condition", so that we have
1821                         --  a statement for the resulting decisions.
1822
1823                         Extend_Statement_Sequence (Elif, 'I');
1824                         Process_Decisions_Defer (Condition (Elif), 'I');
1825                         Set_Statement_Entry;
1826
1827                         --  An ELSIF part is never guaranteed to have
1828                         --  been executed, following statements are only
1829                         --  dominated by the initial IF statement.
1830
1831                         Current_Dominant := Saved_Dominant;
1832
1833                         --  Traverse the statements in the ELSIF
1834
1835                         Traverse_Declarations_Or_Statements
1836                           (L => Then_Statements (Elif),
1837                            D => ('T', Elif));
1838                         Next (Elif);
1839                      end loop;
1840                   end;
1841                end if;
1842
1843                --  Finally traverse the ELSE statements if present
1844
1845                Traverse_Declarations_Or_Statements
1846                  (L => Else_Statements (N),
1847                   D => ('F', Current_Test));
1848
1849             --  CASE statement, which breaks the current statement sequence,
1850             --  but we include the expression in the current sequence.
1851
1852             when N_Case_Statement =>
1853                Extend_Statement_Sequence (N, 'C');
1854                Process_Decisions_Defer (Expression (N), 'X');
1855                Set_Statement_Entry;
1856
1857                --  Process case branches, all of which are dominated by the
1858                --  CASE statement.
1859
1860                declare
1861                   Alt : Node_Id;
1862                begin
1863                   Alt := First (Alternatives (N));
1864                   while Present (Alt) loop
1865                      Traverse_Declarations_Or_Statements
1866                        (L => Statements (Alt),
1867                         D => Current_Dominant);
1868                      Next (Alt);
1869                   end loop;
1870                end;
1871
1872             --  ACCEPT statement
1873
1874             when N_Accept_Statement =>
1875                Extend_Statement_Sequence (N, 'A');
1876                Set_Statement_Entry;
1877
1878                --  Process sequence of statements, dominant is the ACCEPT
1879                --  statement.
1880
1881                Traverse_Handled_Statement_Sequence
1882                  (N => Handled_Statement_Sequence (N),
1883                   D => Current_Dominant);
1884
1885             --  SELECT
1886
1887             when N_Selective_Accept =>
1888                Extend_Statement_Sequence (N, 'S');
1889                Set_Statement_Entry;
1890
1891                --  Process alternatives
1892
1893                declare
1894                   Alt   : Node_Id;
1895                   Guard : Node_Id;
1896                   S_Dom : Dominant_Info;
1897
1898                begin
1899                   Alt := First (Select_Alternatives (N));
1900                   while Present (Alt) loop
1901                      S_Dom := Current_Dominant;
1902                      Guard := Condition (Alt);
1903
1904                      if Present (Guard) then
1905                         Process_Decisions
1906                           (Guard,
1907                            'G',
1908                            Pragma_Sloc => No_Location);
1909                         Current_Dominant := ('T', Guard);
1910                      end if;
1911
1912                      Traverse_One (Alt);
1913
1914                      Current_Dominant := S_Dom;
1915                      Next (Alt);
1916                   end loop;
1917                end;
1918
1919                Traverse_Declarations_Or_Statements
1920                  (L => Else_Statements (N),
1921                   D => Current_Dominant);
1922
1923             when N_Timed_Entry_Call | N_Conditional_Entry_Call =>
1924                Extend_Statement_Sequence (N, 'S');
1925                Set_Statement_Entry;
1926
1927                --  Process alternatives
1928
1929                Traverse_One (Entry_Call_Alternative (N));
1930
1931                if Nkind (N) = N_Timed_Entry_Call then
1932                   Traverse_One (Delay_Alternative (N));
1933                else
1934                   Traverse_Declarations_Or_Statements
1935                     (L => Else_Statements (N),
1936                      D => Current_Dominant);
1937                end if;
1938
1939             when N_Asynchronous_Select =>
1940                Extend_Statement_Sequence (N, 'S');
1941                Set_Statement_Entry;
1942
1943                Traverse_One (Triggering_Alternative (N));
1944                Traverse_Declarations_Or_Statements
1945                  (L => Statements (Abortable_Part (N)),
1946                   D => Current_Dominant);
1947
1948             when N_Accept_Alternative =>
1949                Traverse_Declarations_Or_Statements
1950                  (L => Statements (N),
1951                   D => Current_Dominant,
1952                   P => Accept_Statement (N));
1953
1954             when N_Entry_Call_Alternative =>
1955                Traverse_Declarations_Or_Statements
1956                  (L => Statements (N),
1957                   D => Current_Dominant,
1958                   P => Entry_Call_Statement (N));
1959
1960             when N_Delay_Alternative =>
1961                Traverse_Declarations_Or_Statements
1962                  (L => Statements (N),
1963                   D => Current_Dominant,
1964                   P => Delay_Statement (N));
1965
1966             when N_Triggering_Alternative =>
1967                Traverse_Declarations_Or_Statements
1968                  (L => Statements (N),
1969                   D => Current_Dominant,
1970                   P => Triggering_Statement (N));
1971
1972             when N_Terminate_Alternative =>
1973
1974                --  It is dubious to emit a statement SCO for a TERMINATE
1975                --  alternative, since no code is actually executed if the
1976                --  alternative is selected -- the tasking runtime call just
1977                --  never returns???
1978
1979                Extend_Statement_Sequence (N, ' ');
1980                Set_Statement_Entry;
1981
1982             --  Unconditional exit points, which are included in the current
1983             --  statement sequence, but then terminate it
1984
1985             when N_Requeue_Statement |
1986                  N_Goto_Statement    |
1987                  N_Raise_Statement   =>
1988                Extend_Statement_Sequence (N, ' ');
1989                Set_Statement_Entry;
1990                Current_Dominant := No_Dominant;
1991
1992             --  Simple return statement. which is an exit point, but we
1993             --  have to process the return expression for decisions.
1994
1995             when N_Simple_Return_Statement =>
1996                Extend_Statement_Sequence (N, ' ');
1997                Process_Decisions_Defer (Expression (N), 'X');
1998                Set_Statement_Entry;
1999                Current_Dominant := No_Dominant;
2000
2001             --  Extended return statement
2002
2003             when N_Extended_Return_Statement =>
2004                Extend_Statement_Sequence (N, 'R');
2005                Process_Decisions_Defer
2006                  (Return_Object_Declarations (N), 'X');
2007                Set_Statement_Entry;
2008
2009                Traverse_Handled_Statement_Sequence
2010                  (N => Handled_Statement_Sequence (N),
2011                   D => Current_Dominant);
2012
2013                Current_Dominant := No_Dominant;
2014
2015             --  Loop ends the current statement sequence, but we include
2016             --  the iteration scheme if present in the current sequence.
2017             --  But the body of the loop starts a new sequence, since it
2018             --  may not be executed as part of the current sequence.
2019
2020             when N_Loop_Statement =>
2021                declare
2022                   ISC            : constant Node_Id := Iteration_Scheme (N);
2023                   Inner_Dominant : Dominant_Info    := No_Dominant;
2024
2025                begin
2026                   if Present (ISC) then
2027
2028                      --  If iteration scheme present, extend the current
2029                      --  statement sequence to include the iteration scheme
2030                      --  and process any decisions it contains.
2031
2032                      --  While loop
2033
2034                      if Present (Condition (ISC)) then
2035                         Extend_Statement_Sequence (N, 'W');
2036                         Process_Decisions_Defer (Condition (ISC), 'W');
2037
2038                         --  Set more specific dominant for inner statements
2039                         --  (the control sloc for the decision is that of
2040                         --  the WHILE token).
2041
2042                         Inner_Dominant := ('T', ISC);
2043
2044                      --  For loop
2045
2046                      else
2047                         Extend_Statement_Sequence (N, 'F');
2048                         Process_Decisions_Defer
2049                           (Loop_Parameter_Specification (ISC), 'X');
2050                      end if;
2051                   end if;
2052
2053                   Set_Statement_Entry;
2054
2055                   if Inner_Dominant = No_Dominant then
2056                      Inner_Dominant := Current_Dominant;
2057                   end if;
2058
2059                   Traverse_Declarations_Or_Statements
2060                     (L => Statements (N),
2061                      D => Inner_Dominant);
2062                end;
2063
2064             --  Pragma
2065
2066             when N_Pragma =>
2067
2068                --  Record sloc of pragma (pragmas don't nest)
2069
2070                pragma Assert (Current_Pragma_Sloc = No_Location);
2071                Current_Pragma_Sloc := Sloc (N);
2072
2073                --  Processing depends on the kind of pragma
2074
2075                declare
2076                   Nam : constant Name_Id := Pragma_Name (N);
2077                   Arg : Node_Id          :=
2078                           First (Pragma_Argument_Associations (N));
2079                   Typ : Character;
2080
2081                begin
2082                   case Nam is
2083                      when Name_Assert         |
2084                           Name_Assert_And_Cut |
2085                           Name_Assume         |
2086                           Name_Check          |
2087                           Name_Loop_Invariant |
2088                           Name_Precondition   |
2089                           Name_Postcondition  =>
2090
2091                         --  For Assert/Check/Precondition/Postcondition, we
2092                         --  must generate a P entry for the decision. Note
2093                         --  that this is done unconditionally at this stage.
2094                         --  Output for disabled pragmas is suppressed later
2095                         --  on when we output the decision line in Put_SCOs,
2096                         --  depending on setting by Set_SCO_Pragma_Enabled.
2097
2098                         if Nam = Name_Check then
2099                            Next (Arg);
2100                         end if;
2101
2102                         Process_Decisions_Defer (Expression (Arg), 'P');
2103                         Typ := 'p';
2104
2105                         --  Pre/postconditions can be inherited so SCO should
2106                         --  never be deactivated???
2107
2108                      when Name_Debug =>
2109                         if Present (Arg) and then Present (Next (Arg)) then
2110
2111                            --  Case of a dyadic pragma Debug: first argument
2112                            --  is a P decision, any nested decision in the
2113                            --  second argument is an X decision.
2114
2115                            Process_Decisions_Defer (Expression (Arg), 'P');
2116                            Next (Arg);
2117                         end if;
2118
2119                         Process_Decisions_Defer (Expression (Arg), 'X');
2120                         Typ := 'p';
2121
2122                      --  For all other pragmas, we generate decision entries
2123                      --  for any embedded expressions, and the pragma is
2124                      --  never disabled.
2125
2126                      --  Should generate P decisions (not X) for assertion
2127                      --  related pragmas: [Type_]Invariant,
2128                      --  [{Static,Dynamic}_]Predicate???
2129
2130                      when others =>
2131                         Process_Decisions_Defer (N, 'X');
2132                         Typ := 'P';
2133                   end case;
2134
2135                   --  Add statement SCO
2136
2137                   Extend_Statement_Sequence (N, Typ);
2138
2139                   Current_Pragma_Sloc := No_Location;
2140                end;
2141
2142             --  Object declaration. Ignored if Prev_Ids is set, since the
2143             --  parser generates multiple instances of the whole declaration
2144             --  if there is more than one identifier declared, and we only
2145             --  want one entry in the SCOs, so we take the first, for which
2146             --  Prev_Ids is False.
2147
2148             when N_Object_Declaration | N_Number_Declaration =>
2149                if not Prev_Ids (N) then
2150                   Extend_Statement_Sequence (N, 'o');
2151
2152                   if Has_Decision (N) then
2153                      Process_Decisions_Defer (N, 'X');
2154                   end if;
2155                end if;
2156
2157             --  All other cases, which extend the current statement sequence
2158             --  but do not terminate it, even if they have nested decisions.
2159
2160             when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
2161                Extend_Statement_Sequence (N, 't');
2162                Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
2163                Set_Statement_Entry;
2164
2165                Traverse_Sync_Definition (N);
2166
2167             when N_Single_Protected_Declaration | N_Single_Task_Declaration =>
2168                Extend_Statement_Sequence (N, 'o');
2169                Set_Statement_Entry;
2170
2171                Traverse_Sync_Definition (N);
2172
2173             when others =>
2174
2175                --  Determine required type character code, or ASCII.NUL if
2176                --  no SCO should be generated for this node.
2177
2178                declare
2179                   NK  : constant Node_Kind := Nkind (N);
2180                   Typ : Character;
2181
2182                begin
2183                   case NK is
2184                      when N_Full_Type_Declaration         |
2185                           N_Incomplete_Type_Declaration   |
2186                           N_Private_Type_Declaration      |
2187                           N_Private_Extension_Declaration =>
2188                         Typ := 't';
2189
2190                      when N_Subtype_Declaration           =>
2191                         Typ := 's';
2192
2193                      when N_Renaming_Declaration          =>
2194                         Typ := 'r';
2195
2196                      when N_Generic_Instantiation         =>
2197                         Typ := 'i';
2198
2199                      when N_Representation_Clause         |
2200                           N_Use_Package_Clause            |
2201                           N_Use_Type_Clause               |
2202                           N_Package_Body_Stub             |
2203                           N_Task_Body_Stub                |
2204                           N_Protected_Body_Stub           =>
2205                         Typ := ASCII.NUL;
2206
2207                      when N_Procedure_Call_Statement =>
2208                         Typ := ' ';
2209
2210                      when others                          =>
2211                         if NK in N_Statement_Other_Than_Procedure_Call then
2212                            Typ := ' ';
2213                         else
2214                            Typ := 'd';
2215                         end if;
2216                   end case;
2217
2218                   if Typ /= ASCII.NUL then
2219                      Extend_Statement_Sequence (N, Typ);
2220                   end if;
2221                end;
2222
2223                --  Process any embedded decisions
2224
2225                if Has_Decision (N) then
2226                   Process_Decisions_Defer (N, 'X');
2227                end if;
2228          end case;
2229
2230          --  Process aspects if present
2231
2232          Traverse_Aspects (N);
2233       end Traverse_One;
2234
2235    --  Start of processing for Traverse_Declarations_Or_Statements
2236
2237    begin
2238       --  Process single prefixed node
2239
2240       if Present (P) then
2241          Traverse_One (P);
2242       end if;
2243
2244       --  Loop through statements or declarations
2245
2246       if Is_Non_Empty_List (L) then
2247          N := First (L);
2248          while Present (N) loop
2249
2250             --  Note: For separate bodies, we see the tree after Par.Labl has
2251             --  introduced implicit labels, so we need to ignore those nodes.
2252
2253             if Nkind (N) /= N_Implicit_Label_Declaration then
2254                Traverse_One (N);
2255             end if;
2256
2257             Next (N);
2258          end loop;
2259
2260       end if;
2261
2262       --  End sequence of statements and flush deferred decisions
2263
2264       if Present (P) or else Is_Non_Empty_List (L) then
2265          Set_Statement_Entry;
2266       end if;
2267
2268       return Current_Dominant;
2269    end Traverse_Declarations_Or_Statements;
2270
2271    ------------------------------------------
2272    -- Traverse_Generic_Package_Declaration --
2273    ------------------------------------------
2274
2275    procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
2276    begin
2277       Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
2278       Traverse_Package_Declaration (N);
2279    end Traverse_Generic_Package_Declaration;
2280
2281    -----------------------------------------
2282    -- Traverse_Handled_Statement_Sequence --
2283    -----------------------------------------
2284
2285    procedure Traverse_Handled_Statement_Sequence
2286      (N : Node_Id;
2287       D : Dominant_Info := No_Dominant)
2288    is
2289       Handler : Node_Id;
2290
2291    begin
2292       --  For package bodies without a statement part, the parser adds an empty
2293       --  one, to normalize the representation. The null statement therein,
2294       --  which does not come from source, does not get a SCO.
2295
2296       if Present (N) and then Comes_From_Source (N) then
2297          Traverse_Declarations_Or_Statements (Statements (N), D);
2298
2299          if Present (Exception_Handlers (N)) then
2300             Handler := First (Exception_Handlers (N));
2301             while Present (Handler) loop
2302                Traverse_Declarations_Or_Statements
2303                  (L => Statements (Handler),
2304                   D => ('E', Handler));
2305                Next (Handler);
2306             end loop;
2307          end if;
2308       end if;
2309    end Traverse_Handled_Statement_Sequence;
2310
2311    ---------------------------
2312    -- Traverse_Package_Body --
2313    ---------------------------
2314
2315    procedure Traverse_Package_Body (N : Node_Id) is
2316       Dom : Dominant_Info;
2317    begin
2318       --  The first statement in the handled sequence of statements is
2319       --  dominated by the elaboration of the last declaration.
2320
2321       Dom := Traverse_Declarations_Or_Statements (Declarations (N));
2322
2323       Traverse_Handled_Statement_Sequence
2324         (Handled_Statement_Sequence (N), Dom);
2325    end Traverse_Package_Body;
2326
2327    ----------------------------------
2328    -- Traverse_Package_Declaration --
2329    ----------------------------------
2330
2331    procedure Traverse_Package_Declaration
2332      (N : Node_Id;
2333       D : Dominant_Info := No_Dominant)
2334    is
2335       Spec : constant Node_Id := Specification (N);
2336       Dom  : Dominant_Info;
2337
2338    begin
2339       Dom :=
2340         Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D);
2341
2342       --  First private declaration is dominated by last visible declaration
2343
2344       Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
2345    end Traverse_Package_Declaration;
2346
2347    ------------------------------
2348    -- Traverse_Sync_Definition --
2349    ------------------------------
2350
2351    procedure Traverse_Sync_Definition (N : Node_Id) is
2352       Dom_Info : Dominant_Info := ('S', N);
2353       --  The first declaration is dominated by the protected or task [type]
2354       --  declaration.
2355
2356       Sync_Def : Node_Id;
2357       --  N's protected or task definition
2358
2359       Vis_Decl : List_Id;
2360       --  Sync_Def's Visible_Declarations
2361
2362    begin
2363       case Nkind (N) is
2364          when N_Single_Protected_Declaration | N_Protected_Type_Declaration =>
2365             Sync_Def := Protected_Definition (N);
2366
2367          when N_Single_Task_Declaration      | N_Task_Type_Declaration      =>
2368             Sync_Def := Task_Definition (N);
2369
2370          when others =>
2371             raise Program_Error;
2372       end case;
2373
2374       Vis_Decl := Visible_Declarations (Sync_Def);
2375
2376       Dom_Info := Traverse_Declarations_Or_Statements
2377                     (L => Vis_Decl,
2378                      D => Dom_Info);
2379
2380       --  If visible declarations are present, the first private declaration
2381       --  is dominated by the last visible declaration.
2382
2383       Traverse_Declarations_Or_Statements
2384         (L => Private_Declarations (Sync_Def),
2385          D => Dom_Info);
2386    end Traverse_Sync_Definition;
2387
2388    --------------------------------------
2389    -- Traverse_Subprogram_Or_Task_Body --
2390    --------------------------------------
2391
2392    procedure Traverse_Subprogram_Or_Task_Body
2393      (N : Node_Id;
2394       D : Dominant_Info := No_Dominant)
2395    is
2396       Decls    : constant List_Id := Declarations (N);
2397       Dom_Info : Dominant_Info := D;
2398    begin
2399       --  If declarations are present, the first statement is dominated by the
2400       --  last declaration.
2401
2402       Dom_Info := Traverse_Declarations_Or_Statements
2403                     (L => Decls, D => Dom_Info);
2404
2405       Traverse_Handled_Statement_Sequence
2406         (N => Handled_Statement_Sequence (N),
2407          D => Dom_Info);
2408    end Traverse_Subprogram_Or_Task_Body;
2409
2410    -------------------------
2411    -- SCO_Record_Filtered --
2412    -------------------------
2413
2414    procedure SCO_Record_Filtered is
2415       type Decision is record
2416          Kind : Character;
2417          --  Type of the SCO decision (see comments for SCO_Table_Entry.C1)
2418
2419          Sloc : Source_Location;
2420
2421          Top  : Nat;
2422          --  Index in the SCO_Raw_Table for the root operator/condition for the
2423          --  expression that controls the decision.
2424       end record;
2425       --  Decision descriptor: used to gather information about a candidate
2426       --  SCO decision.
2427
2428       package Pending_Decisions is new Table.Table
2429         (Table_Component_Type => Decision,
2430          Table_Index_Type     => Nat,
2431          Table_Low_Bound      => 1,
2432          Table_Initial        => 1000,
2433          Table_Increment      => 200,
2434          Table_Name           => "Filter_Pending_Decisions");
2435       --  Table used to hold decisions to process during the collection pass
2436
2437       function Is_Decision (Idx : Nat) return Boolean;
2438       --  Return if the expression tree starting at Idx has adjacent nested
2439       --  nodes that make a decision.
2440
2441       procedure Search_Nested_Decisions (Idx : in out Nat);
2442       --  Collect decisions to add to the filtered SCO table starting at the
2443       --  node at Idx in the SCO raw table. This node must not be part of an
2444       --  already-processed decision. Set Idx to the first node index passed
2445       --  the whole expression tree.
2446
2447       procedure Skip_Decision
2448         (Idx                      : in out Nat;
2449          Process_Nested_Decisions : Boolean);
2450       --  Skip all the nodes that belong to the decision starting at Idx. If
2451       --  Process_Nested_Decision, call Search_Nested_Decisions on the first
2452       --  nested nodes that do not belong to the decision. Set Idx to the first
2453       --  node index passed the whole expression tree.
2454
2455       procedure Collect_Decisions
2456         (D    : Decision;
2457          Next : out Nat);
2458       --  Collect decisions to add to the filtered SCO table starting at the
2459       --  D decision (including it and its nested operators/conditions). Set
2460       --  Next to the first node index passed the whole decision.
2461
2462       procedure Compute_Range
2463         (Idx  : in out Nat;
2464          From : out Source_Location;
2465          To   : out Source_Location);
2466       --  Compute the source location range for the expression tree starting at
2467       --  Idx in the SCO raw table. Store its bounds in From and To.
2468
2469       procedure Add_Expression_Tree (Idx : in out Nat);
2470       --  Add SCO raw table entries for the decision controlling expression
2471       --  tree starting at Idx to the filtered SCO table.
2472
2473       procedure Process_Pending_Decisions
2474         (Original_Decision : SCO_Table_Entry);
2475       --  Complete the filtered SCO table using collected decisions. Output
2476       --  decisions inherit the pragma information from the original decision.
2477
2478       -----------------
2479       -- Is_Decision --
2480       -----------------
2481
2482       function Is_Decision (Idx : Nat) return Boolean is
2483          Index : Nat := Idx;
2484
2485       begin
2486          loop
2487             declare
2488                T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
2489
2490             begin
2491                case T.C1 is
2492                   when ' ' =>
2493                      return False;
2494
2495                   when '!' =>
2496
2497                      --  This is a decision iff the only operand of the NOT
2498                      --  operator could be a standalone decision.
2499
2500                      Index := Idx + 1;
2501
2502                   when others =>
2503
2504                      --  This node is a logical operator (and thus could be a
2505                      --  standalone decision) iff it is a short circuit
2506                      --  operator.
2507
2508                      return T.C2 /= '?';
2509
2510                end case;
2511             end;
2512          end loop;
2513       end Is_Decision;
2514
2515       -----------------------------
2516       -- Search_Nested_Decisions --
2517       -----------------------------
2518
2519       procedure Search_Nested_Decisions (Idx : in out Nat)
2520       is
2521       begin
2522          loop
2523             declare
2524                T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2525
2526             begin
2527                case T.C1 is
2528                   when ' ' =>
2529                      Idx := Idx + 1;
2530                      exit;
2531
2532                   when '!' =>
2533                      Collect_Decisions
2534                        ((Kind => 'X',
2535                          Sloc => T.From,
2536                          Top  => Idx),
2537                         Idx);
2538                      exit;
2539
2540                   when others =>
2541                      if T.C2 = '?' then
2542
2543                         --  This in not a logical operator: start looking for
2544                         --  nested decisions from here. Recurse over the left
2545                         --  child and let the loop take care of the right one.
2546
2547                         Idx := Idx + 1;
2548                         Search_Nested_Decisions (Idx);
2549
2550                      else
2551                         --  We found a nested decision
2552
2553                         Collect_Decisions
2554                           ((Kind => 'X',
2555                             Sloc => T.From,
2556                             Top  => Idx),
2557                             Idx);
2558                         exit;
2559                      end if;
2560                end case;
2561             end;
2562          end loop;
2563       end Search_Nested_Decisions;
2564
2565       -------------------
2566       -- Skip_Decision --
2567       -------------------
2568
2569       procedure Skip_Decision
2570         (Idx                      : in out Nat;
2571          Process_Nested_Decisions : Boolean)
2572       is
2573       begin
2574          loop
2575             declare
2576                T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2577
2578             begin
2579                Idx := Idx + 1;
2580
2581                case T.C1 is
2582                   when ' ' =>
2583                      exit;
2584
2585                   when '!' =>
2586
2587                      --  This NOT operator belongs to the outside decision:
2588                      --  just skip it.
2589
2590                      null;
2591
2592                   when others =>
2593                      if T.C2 = '?' and then Process_Nested_Decisions then
2594
2595                         --  This in not a logical operator: start looking for
2596                         --  nested decisions from here. Recurse over the left
2597                         --  child and let the loop take care of the right one.
2598
2599                         Search_Nested_Decisions (Idx);
2600
2601                      else
2602                         --  This is a logical operator, so it belongs to the
2603                         --  outside decision: skip its left child, then let the
2604                         --  loop take care of the right one.
2605
2606                         Skip_Decision (Idx, Process_Nested_Decisions);
2607                      end if;
2608                end case;
2609             end;
2610          end loop;
2611       end Skip_Decision;
2612
2613       -----------------------
2614       -- Collect_Decisions --
2615       -----------------------
2616
2617       procedure Collect_Decisions
2618         (D    : Decision;
2619          Next : out Nat)
2620       is
2621          Idx : Nat := D.Top;
2622       begin
2623          if D.Kind /= 'X' or else Is_Decision (D.Top) then
2624             Pending_Decisions.Append (D);
2625          end if;
2626
2627          Skip_Decision (Idx, True);
2628          Next := Idx;
2629       end Collect_Decisions;
2630
2631       -------------------
2632       -- Compute_Range --
2633       -------------------
2634
2635       procedure Compute_Range
2636         (Idx  : in out Nat;
2637          From : out Source_Location;
2638          To   : out Source_Location)
2639       is
2640          Sloc_F, Sloc_T : Source_Location := No_Source_Location;
2641
2642          procedure Process_One;
2643          --  Process one node of the tree, and recurse over children. Update
2644          --  Idx during the traversal.
2645
2646          -----------------
2647          -- Process_One --
2648          -----------------
2649
2650          procedure Process_One is
2651          begin
2652             if Sloc_F = No_Source_Location
2653                  or else
2654                SCO_Raw_Table.Table (Idx).From < Sloc_F
2655             then
2656                Sloc_F := SCO_Raw_Table.Table (Idx).From;
2657             end if;
2658             if Sloc_T = No_Source_Location
2659                  or else
2660                Sloc_T < SCO_Raw_Table.Table (Idx).To
2661             then
2662                Sloc_T := SCO_Raw_Table.Table (Idx).To;
2663             end if;
2664
2665             if SCO_Raw_Table.Table (Idx).C1 = ' ' then
2666
2667                --  This is a condition: nothing special to do
2668
2669                Idx := Idx + 1;
2670
2671             elsif SCO_Raw_Table.Table (Idx).C1 = '!' then
2672
2673                --  The "not" operator has only one operand
2674
2675                Idx := Idx + 1;
2676                Process_One;
2677
2678             else
2679                --  This is an AND THEN or OR ELSE logical operator: follow the
2680                --  left, then the right operands.
2681
2682                Idx := Idx + 1;
2683
2684                Process_One;
2685                Process_One;
2686             end if;
2687          end Process_One;
2688
2689       --  Start of processing for Compute_Range
2690
2691       begin
2692          Process_One;
2693          From := Sloc_F;
2694          To := Sloc_T;
2695       end Compute_Range;
2696
2697       -------------------------
2698       -- Add_Expression_Tree --
2699       -------------------------
2700
2701       procedure Add_Expression_Tree (Idx : in out Nat)
2702       is
2703          Node_Idx : constant Nat := Idx;
2704          T        : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
2705          From, To : Source_Location;
2706
2707       begin
2708          case T.C1 is
2709             when ' ' =>
2710
2711                --  This is a single condition. Add an entry for it and move on
2712
2713                SCO_Table.Append (T);
2714                Idx := Idx + 1;
2715
2716             when '!' =>
2717
2718                --  This is a NOT operator: add an entry for it and browse its
2719                --  only child.
2720
2721                SCO_Table.Append (T);
2722                Idx := Idx + 1;
2723                Add_Expression_Tree (Idx);
2724
2725             when others =>
2726
2727                --  This must be an AND/OR/AND THEN/OR ELSE operator
2728
2729                if T.C2 = '?' then
2730
2731                   --  This is not a short circuit operator: consider this one
2732                   --  and all its children as a single condition.
2733
2734                   Compute_Range (Idx, From, To);
2735                   SCO_Table.Append
2736                     ((From               => From,
2737                       To                 => To,
2738                       C1                 => ' ',
2739                       C2                 => 'c',
2740                       Last               => False,
2741                       Pragma_Sloc        => No_Location,
2742                       Pragma_Aspect_Name => No_Name));
2743
2744                else
2745                   --  This is a real short circuit operator: add an entry for
2746                   --  it and browse its children.
2747
2748                   SCO_Table.Append (T);
2749                   Idx := Idx + 1;
2750                   Add_Expression_Tree (Idx);
2751                   Add_Expression_Tree (Idx);
2752                end if;
2753          end case;
2754       end Add_Expression_Tree;
2755
2756       -------------------------------
2757       -- Process_Pending_Decisions --
2758       -------------------------------
2759
2760       procedure Process_Pending_Decisions
2761         (Original_Decision : SCO_Table_Entry)
2762       is
2763       begin
2764          for Index in 1 .. Pending_Decisions.Last loop
2765             declare
2766                D   : Decision renames Pending_Decisions.Table (Index);
2767                Idx : Nat := D.Top;
2768
2769             begin
2770                --  Add a SCO table entry for the decision itself
2771
2772                pragma Assert (D.Kind /= ' ');
2773
2774                SCO_Table.Append
2775                  ((To                 => No_Source_Location,
2776                    From               => D.Sloc,
2777                    C1                 => D.Kind,
2778                    C2                 => ' ',
2779                    Last               => False,
2780                    Pragma_Sloc        => Original_Decision.Pragma_Sloc,
2781                    Pragma_Aspect_Name =>
2782                       Original_Decision.Pragma_Aspect_Name));
2783
2784                --  Then add ones for its nested operators/operands. Do not
2785                --  forget to tag its *last* entry as such.
2786
2787                Add_Expression_Tree (Idx);
2788                SCO_Table.Table (SCO_Table.Last).Last := True;
2789             end;
2790          end loop;
2791
2792          --  Clear the pending decisions list
2793          Pending_Decisions.Set_Last (0);
2794       end Process_Pending_Decisions;
2795
2796    --  Start of processing for SCO_Record_Filtered
2797
2798    begin
2799       --  Filtering must happen only once: do nothing if it this pass was
2800       --  already run.
2801
2802       if SCO_Generation_State = Filtered then
2803          return;
2804       else
2805          pragma Assert (SCO_Generation_State = Raw);
2806          SCO_Generation_State := Filtered;
2807       end if;
2808
2809       --  Loop through all SCO entries under SCO units
2810
2811       for Unit_Idx in 1 .. SCO_Unit_Table.Last loop
2812          declare
2813             Unit : SCO_Unit_Table_Entry
2814                renames SCO_Unit_Table.Table (Unit_Idx);
2815
2816             Idx : Nat := Unit.From;
2817             --  Index of the current SCO raw table entry
2818
2819             New_From : constant Nat := SCO_Table.Last + 1;
2820             --  After copying SCO enties of interest to the final table, we
2821             --  will have to change the From/To indexes this unit targets.
2822             --  This constant keeps track of the new From index.
2823
2824          begin
2825             while Idx <= Unit.To loop
2826                declare
2827                   T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2828
2829                begin
2830                   case T.C1 is
2831
2832                      --  Decision (of any kind, including pragmas and aspects)
2833
2834                      when 'E' | 'G' | 'I' | 'W' | 'X' | 'P' | 'a' | 'A' =>
2835                         if SCO_Pragma_Disabled (T.Pragma_Sloc) then
2836
2837                            --  Skip SCO entries for decisions in disabled
2838                            --  constructs (pragmas or aspects).
2839
2840                            Idx := Idx + 1;
2841                            Skip_Decision (Idx, False);
2842
2843                         else
2844                            Collect_Decisions
2845                              ((Kind => T.C1,
2846                                Sloc => T.From,
2847                                Top  => Idx + 1),
2848                               Idx);
2849                            Process_Pending_Decisions (T);
2850                         end if;
2851
2852                      --  There is no translation/filtering to do for other kind
2853                      --  of SCO items (statements, dominance markers, etc.).
2854
2855                      when '|' | '&' | '!' | ' ' =>
2856
2857                         --  SCO logical operators and conditions cannot exist
2858                         --  on their own: they must be inside a decision (such
2859                         --  entries must have been skipped by
2860                         --  Collect_Decisions).
2861
2862                         raise Program_Error;
2863
2864                      when others =>
2865                         SCO_Table.Append (T);
2866                         Idx := Idx + 1;
2867                   end case;
2868                end;
2869             end loop;
2870
2871             --  Now, update the SCO entry indexes in the unit entry
2872
2873             Unit.From := New_From;
2874             Unit.To := SCO_Table.Last;
2875          end;
2876       end loop;
2877
2878       --  Then clear the raw table to free bytes
2879
2880       SCO_Raw_Table.Free;
2881    end SCO_Record_Filtered;
2882
2883 end Par_SCO;