gcc/ada/ali.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  A L I                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2021, 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 Butil;  use Butil;
  27 with Debug;  use Debug;
  28 with Fname;  use Fname;
  29 with Opt;    use Opt;
  30 with Osint;  use Osint;
  31 with Output; use Output;
  32 with Snames; use Snames;
  33
  34 with GNAT;                 use GNAT;
  35 with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
  36
  37 package body ALI is
  38
  39    use ASCII;
  40    --  Make control characters visible
  41
  42    -----------
  43    -- Types --
  44    -----------
  45
  46    --  The following type represents an invocation construct
  47
  48    type Invocation_Construct_Record is record
  49       Body_Placement : Declaration_Placement_Kind := No_Declaration_Placement;
  50       --  The location of the invocation construct's body with respect to the
  51       --  unit where it is declared.
  52
  53       Kind : Invocation_Construct_Kind := Regular_Construct;
  54       --  The nature of the invocation construct
  55
  56       Signature : Invocation_Signature_Id := No_Invocation_Signature;
  57       --  The invocation signature that uniquely identifies the invocation
  58       --  construct in the ALI space.
  59
  60       Spec_Placement : Declaration_Placement_Kind := No_Declaration_Placement;
  61       --  The location of the invocation construct's spec with respect to the
  62       --  unit where it is declared.
  63    end record;
  64
  65    --  The following type represents an invocation relation. It associates an
  66    --  invoker that activates/calls/instantiates with a target.
  67
  68    type Invocation_Relation_Record is record
  69       Extra : Name_Id := No_Name;
  70       --  The name of an additional entity used in error diagnostics
  71
  72       Invoker : Invocation_Signature_Id := No_Invocation_Signature;
  73       --  The invocation signature that uniquely identifies the invoker within
  74       --  the ALI space.
  75
  76       Kind : Invocation_Kind := No_Invocation;
  77       --  The nature of the invocation
  78
  79       Target : Invocation_Signature_Id := No_Invocation_Signature;
  80       --  The invocation signature that uniquely identifies the target within
  81       --  the ALI space.
  82    end record;
  83
  84    --  The following type represents an invocation signature. Its purpose is
  85    --  to uniquely identify an invocation construct within the ALI space. The
  86    --  signature comprises several pieces, some of which are used in error
  87    --  diagnostics by the binder. Identification issues are resolved as
  88    --  follows:
  89    --
  90    --    * The Column, Line, and Locations attributes together differentiate
  91    --      between homonyms. In most cases, the Column and Line are sufficient
  92    --      except when generic instantiations are involved. Together, the three
  93    --      attributes offer a sequence of column-line pairs that eventually
  94    --      reflect the location within the generic template.
  95    --
  96    --    * The Name attribute differentiates between invocation constructs at
  97    --      the scope level. Since it is illegal for two entities with the same
  98    --      name to coexist in the same scope, the Name attribute is sufficient
  99    --      to distinguish them. Overloaded entities are already handled by the
 100    --      Column, Line, and Locations attributes.
 101    --
 102    --    * The Scope attribute differentiates between invocation constructs at
 103    --      various levels of nesting.
 104
 105    type Invocation_Signature_Record is record
 106       Column : Nat := 0;
 107       --  The column number where the invocation construct is declared
 108
 109       Line : Nat := 0;
 110       --  The line number where the invocation construct is declared
 111
 112       Locations : Name_Id := No_Name;
 113       --  Sequence of column and line numbers within nested instantiations
 114
 115       Name : Name_Id := No_Name;
 116       --  The name of the invocation construct
 117
 118       Scope : Name_Id := No_Name;
 119       --  The qualified name of the scope where the invocation construct is
 120       --  declared.
 121    end record;
 122
 123    ---------------------
 124    -- Data structures --
 125    ---------------------
 126
 127    package Invocation_Constructs is new Table.Table
 128      (Table_Index_Type     => Invocation_Construct_Id,
 129       Table_Component_Type => Invocation_Construct_Record,
 130       Table_Low_Bound      => First_Invocation_Construct,
 131       Table_Initial        => 2500,
 132       Table_Increment      => 200,
 133       Table_Name           => "Invocation_Constructs");
 134
 135    package Invocation_Relations is new Table.Table
 136      (Table_Index_Type     => Invocation_Relation_Id,
 137       Table_Component_Type => Invocation_Relation_Record,
 138       Table_Low_Bound      => First_Invocation_Relation,
 139       Table_Initial        => 2500,
 140       Table_Increment      => 200,
 141       Table_Name           => "Invocation_Relation");
 142
 143    package Invocation_Signatures is new Table.Table
 144      (Table_Index_Type     => Invocation_Signature_Id,
 145       Table_Component_Type => Invocation_Signature_Record,
 146       Table_Low_Bound      => First_Invocation_Signature,
 147       Table_Initial        => 2500,
 148       Table_Increment      => 200,
 149       Table_Name           => "Invocation_Signatures");
 150
 151    procedure Destroy (IS_Id : in out Invocation_Signature_Id);
 152    --  Destroy an invocation signature with id IS_Id
 153
 154    function Hash
 155      (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type;
 156    --  Obtain the hash of key IS_Rec
 157
 158    package Sig_Map is new Dynamic_Hash_Tables
 159      (Key_Type              => Invocation_Signature_Record,
 160       Value_Type            => Invocation_Signature_Id,
 161       No_Value              => No_Invocation_Signature,
 162       Expansion_Threshold   => 1.5,
 163       Expansion_Factor      => 2,
 164       Compression_Threshold => 0.3,
 165       Compression_Factor    => 2,
 166       "="                   => "=",
 167       Destroy_Value         => Destroy,
 168       Hash                  => Hash);
 169
 170    --  The following map relates invocation signature records to invocation
 171    --  signature ids.
 172
 173    Sig_To_Sig_Map : constant Sig_Map.Dynamic_Hash_Table :=
 174                       Sig_Map.Create (500);
 175
 176    --  The folowing table maps declaration placement kinds to character codes
 177    --  for invocation construct encoding in ALI files.
 178
 179    Declaration_Placement_Codes :
 180      constant array (Declaration_Placement_Kind) of Character :=
 181        (In_Body                  => 'b',
 182         In_Spec                  => 's',
 183         No_Declaration_Placement => 'Z');
 184
 185    Compile_Time_Invocation_Graph_Encoding : Invocation_Graph_Encoding_Kind :=
 186                                               No_Encoding;
 187    --  The invocation-graph encoding format as specified at compile time. Do
 188    --  not manipulate this value directly.
 189
 190    --  The following table maps invocation kinds to character codes for
 191    --  invocation relation encoding in ALI files.
 192
 193    Invocation_Codes :
 194      constant array (Invocation_Kind) of Character :=
 195        (Accept_Alternative                     => 'a',
 196         Access_Taken                           => 'b',
 197         Call                                   => 'c',
 198         Controlled_Adjustment                  => 'd',
 199         Controlled_Finalization                => 'e',
 200         Controlled_Initialization              => 'f',
 201         Default_Initial_Condition_Verification => 'g',
 202         Initial_Condition_Verification         => 'h',
 203         Instantiation                          => 'i',
 204         Internal_Controlled_Adjustment         => 'j',
 205         Internal_Controlled_Finalization       => 'k',
 206         Internal_Controlled_Initialization     => 'l',
 207         Invariant_Verification                 => 'm',
 208         Postcondition_Verification             => 'n',
 209         Protected_Entry_Call                   => 'o',
 210         Protected_Subprogram_Call              => 'p',
 211         Task_Activation                        => 'q',
 212         Task_Entry_Call                        => 'r',
 213         Type_Initialization                    => 's',
 214         No_Invocation                          => 'Z');
 215
 216    --  The following table maps invocation construct kinds to character codes
 217    --  for invocation construct encoding in ALI files.
 218
 219    Invocation_Construct_Codes :
 220      constant array (Invocation_Construct_Kind) of Character :=
 221        (Elaborate_Body_Procedure => 'b',
 222         Elaborate_Spec_Procedure => 's',
 223         Regular_Construct        => 'Z');
 224
 225    --  The following table maps invocation-graph encoding kinds to character
 226    --  codes for invocation-graph encoding in ALI files.
 227
 228    Invocation_Graph_Encoding_Codes :
 229      constant array (Invocation_Graph_Encoding_Kind) of Character :=
 230        (Full_Path_Encoding => 'f',
 231         Endpoints_Encoding => 'e',
 232         No_Encoding        => 'Z');
 233
 234    --  The following table maps invocation-graph line kinds to character codes
 235    --  used in ALI files.
 236
 237    Invocation_Graph_Line_Codes :
 238      constant array (Invocation_Graph_Line_Kind) of Character :=
 239        (Invocation_Construct_Line        => 'c',
 240         Invocation_Graph_Attributes_Line => 'a',
 241         Invocation_Relation_Line         => 'r');
 242
 243    --  The following variable records which characters currently are used as
 244    --  line type markers in the ALI file. This is used in Scan_ALI to detect
 245    --  (or skip) invalid lines.
 246
 247    Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
 248      ('A' | --  argument
 249       'C' | --  SCO information
 250       'D' | --  dependency
 251       'E' | --  external
 252       'G' | --  invocation graph
 253       'I' | --  interrupt
 254       'L' | --  linker option
 255       'M' | --  main program
 256       'N' | --  notes
 257       'P' | --  program
 258       'R' | --  restriction
 259       'S' | --  specific dispatching
 260       'T' | --  task stack information
 261       'U' | --  unit
 262       'V' | --  version
 263       'W' | --  with
 264       'X' | --  xref
 265       'Y' | --  limited_with
 266       'Z'   --  implicit with from instantiation
 267           => True,
 268
 269       --  Still available:
 270
 271       'B' | 'F' | 'H' | 'J' | 'K' | 'O' | 'Q' => False);
 272
 273    ------------------------------
 274    -- Add_Invocation_Construct --
 275    ------------------------------
 276
 277    procedure Add_Invocation_Construct
 278      (Body_Placement : Declaration_Placement_Kind;
 279       Kind           : Invocation_Construct_Kind;
 280       Signature      : Invocation_Signature_Id;
 281       Spec_Placement : Declaration_Placement_Kind;
 282       Update_Units   : Boolean := True)
 283    is
 284    begin
 285       pragma Assert (Present (Signature));
 286
 287       --  Create a invocation construct from the scanned attributes
 288
 289       Invocation_Constructs.Append
 290         ((Body_Placement => Body_Placement,
 291           Kind           => Kind,
 292           Signature      => Signature,
 293           Spec_Placement => Spec_Placement));
 294
 295       --  Update the invocation construct counter of the current unit only when
 296       --  requested by the caller.
 297
 298       if Update_Units then
 299          declare
 300             Curr_Unit : Unit_Record renames Units.Table (Units.Last);
 301
 302          begin
 303             Curr_Unit.Last_Invocation_Construct := Invocation_Constructs.Last;
 304          end;
 305       end if;
 306    end Add_Invocation_Construct;
 307
 308    -----------------------------
 309    -- Add_Invocation_Relation --
 310    -----------------------------
 311
 312    procedure Add_Invocation_Relation
 313      (Extra        : Name_Id;
 314       Invoker      : Invocation_Signature_Id;
 315       Kind         : Invocation_Kind;
 316       Target       : Invocation_Signature_Id;
 317       Update_Units : Boolean := True)
 318    is
 319    begin
 320       pragma Assert (Present (Invoker));
 321       pragma Assert (Kind /= No_Invocation);
 322       pragma Assert (Present (Target));
 323
 324       --  Create an invocation relation from the scanned attributes
 325
 326       Invocation_Relations.Append
 327         ((Extra   => Extra,
 328           Invoker => Invoker,
 329           Kind    => Kind,
 330           Target  => Target));
 331
 332       --  Update the invocation relation counter of the current unit only when
 333       --  requested by the caller.
 334
 335       if Update_Units then
 336          declare
 337             Curr_Unit : Unit_Record renames Units.Table (Units.Last);
 338
 339          begin
 340             Curr_Unit.Last_Invocation_Relation := Invocation_Relations.Last;
 341          end;
 342       end if;
 343    end Add_Invocation_Relation;
 344
 345    --------------------
 346    -- Body_Placement --
 347    --------------------
 348
 349    function Body_Placement
 350      (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind
 351    is
 352    begin
 353       pragma Assert (Present (IC_Id));
 354       return Invocation_Constructs.Table (IC_Id).Body_Placement;
 355    end Body_Placement;
 356
 357    ----------------------------------------
 358    -- Code_To_Declaration_Placement_Kind --
 359    ----------------------------------------
 360
 361    function Code_To_Declaration_Placement_Kind
 362      (Code : Character) return Declaration_Placement_Kind
 363    is
 364    begin
 365       --  Determine which placement kind corresponds to the character code by
 366       --  traversing the contents of the mapping table.
 367
 368       for Kind in Declaration_Placement_Kind loop
 369          if Declaration_Placement_Codes (Kind) = Code then
 370             return Kind;
 371          end if;
 372       end loop;
 373
 374       raise Program_Error;
 375    end Code_To_Declaration_Placement_Kind;
 376
 377    ---------------------------------------
 378    -- Code_To_Invocation_Construct_Kind --
 379    ---------------------------------------
 380
 381    function Code_To_Invocation_Construct_Kind
 382      (Code : Character) return Invocation_Construct_Kind
 383    is
 384    begin
 385       --  Determine which invocation construct kind matches the character code
 386       --  by traversing the contents of the mapping table.
 387
 388       for Kind in Invocation_Construct_Kind loop
 389          if Invocation_Construct_Codes (Kind) = Code then
 390             return Kind;
 391          end if;
 392       end loop;
 393
 394       raise Program_Error;
 395    end Code_To_Invocation_Construct_Kind;
 396
 397    --------------------------------------------
 398    -- Code_To_Invocation_Graph_Encoding_Kind --
 399    --------------------------------------------
 400
 401    function Code_To_Invocation_Graph_Encoding_Kind
 402      (Code : Character) return Invocation_Graph_Encoding_Kind
 403    is
 404    begin
 405       --  Determine which invocation-graph encoding kind matches the character
 406       --  code by traversing the contents of the mapping table.
 407
 408       for Kind in Invocation_Graph_Encoding_Kind loop
 409          if Invocation_Graph_Encoding_Codes (Kind) = Code then
 410             return Kind;
 411          end if;
 412       end loop;
 413
 414       raise Program_Error;
 415    end Code_To_Invocation_Graph_Encoding_Kind;
 416
 417    -----------------------------
 418    -- Code_To_Invocation_Kind --
 419    -----------------------------
 420
 421    function Code_To_Invocation_Kind
 422      (Code : Character) return Invocation_Kind
 423    is
 424    begin
 425       --  Determine which invocation kind corresponds to the character code by
 426       --  traversing the contents of the mapping table.
 427
 428       for Kind in Invocation_Kind loop
 429          if Invocation_Codes (Kind) = Code then
 430             return Kind;
 431          end if;
 432       end loop;
 433
 434       raise Program_Error;
 435    end Code_To_Invocation_Kind;
 436
 437    ----------------------------------------
 438    -- Code_To_Invocation_Graph_Line_Kind --
 439    ----------------------------------------
 440
 441    function Code_To_Invocation_Graph_Line_Kind
 442      (Code : Character) return Invocation_Graph_Line_Kind
 443    is
 444    begin
 445       --  Determine which invocation-graph line kind matches the character
 446       --  code by traversing the contents of the mapping table.
 447
 448       for Kind in Invocation_Graph_Line_Kind loop
 449          if Invocation_Graph_Line_Codes (Kind) = Code then
 450             return Kind;
 451          end if;
 452       end loop;
 453
 454       raise Program_Error;
 455    end Code_To_Invocation_Graph_Line_Kind;
 456
 457    ------------
 458    -- Column --
 459    ------------
 460
 461    function Column (IS_Id : Invocation_Signature_Id) return Nat is
 462    begin
 463       pragma Assert (Present (IS_Id));
 464       return Invocation_Signatures.Table (IS_Id).Column;
 465    end Column;
 466
 467    ----------------------------------------
 468    -- Declaration_Placement_Kind_To_Code --
 469    ----------------------------------------
 470
 471    function Declaration_Placement_Kind_To_Code
 472      (Kind : Declaration_Placement_Kind) return Character
 473    is
 474    begin
 475       return Declaration_Placement_Codes (Kind);
 476    end Declaration_Placement_Kind_To_Code;
 477
 478    -------------
 479    -- Destroy --
 480    -------------
 481
 482    procedure Destroy (IS_Id : in out Invocation_Signature_Id) is
 483       pragma Unreferenced (IS_Id);
 484    begin
 485       null;
 486    end Destroy;
 487
 488    -----------
 489    -- Extra --
 490    -----------
 491
 492    function Extra (IR_Id : Invocation_Relation_Id) return Name_Id is
 493    begin
 494       pragma Assert (Present (IR_Id));
 495       return Invocation_Relations.Table (IR_Id).Extra;
 496    end Extra;
 497
 498    -----------------------------------
 499    -- For_Each_Invocation_Construct --
 500    -----------------------------------
 501
 502    procedure For_Each_Invocation_Construct
 503      (Processor : Invocation_Construct_Processor_Ptr)
 504    is
 505    begin
 506       pragma Assert (Processor /= null);
 507
 508       for IC_Id in Invocation_Constructs.First ..
 509                    Invocation_Constructs.Last
 510       loop
 511          Processor.all (IC_Id);
 512       end loop;
 513    end For_Each_Invocation_Construct;
 514
 515    -----------------------------------
 516    -- For_Each_Invocation_Construct --
 517    -----------------------------------
 518
 519    procedure For_Each_Invocation_Construct
 520      (U_Id      : Unit_Id;
 521       Processor : Invocation_Construct_Processor_Ptr)
 522    is
 523       pragma Assert (Present (U_Id));
 524       pragma Assert (Processor /= null);
 525
 526       U_Rec : Unit_Record renames Units.Table (U_Id);
 527
 528    begin
 529       for IC_Id in U_Rec.First_Invocation_Construct ..
 530                    U_Rec.Last_Invocation_Construct
 531       loop
 532          Processor.all (IC_Id);
 533       end loop;
 534    end For_Each_Invocation_Construct;
 535
 536    ----------------------------------
 537    -- For_Each_Invocation_Relation --
 538    ----------------------------------
 539
 540    procedure For_Each_Invocation_Relation
 541      (Processor : Invocation_Relation_Processor_Ptr)
 542    is
 543    begin
 544       pragma Assert (Processor /= null);
 545
 546       for IR_Id in Invocation_Relations.First ..
 547                    Invocation_Relations.Last
 548       loop
 549          Processor.all (IR_Id);
 550       end loop;
 551    end For_Each_Invocation_Relation;
 552
 553    ----------------------------------
 554    -- For_Each_Invocation_Relation --
 555    ----------------------------------
 556
 557    procedure For_Each_Invocation_Relation
 558      (U_Id      : Unit_Id;
 559       Processor : Invocation_Relation_Processor_Ptr)
 560    is
 561       pragma Assert (Present (U_Id));
 562       pragma Assert (Processor /= null);
 563
 564       U_Rec : Unit_Record renames Units.Table (U_Id);
 565
 566    begin
 567       for IR_Id in U_Rec.First_Invocation_Relation ..
 568                    U_Rec.Last_Invocation_Relation
 569       loop
 570          Processor.all (IR_Id);
 571       end loop;
 572    end For_Each_Invocation_Relation;
 573
 574    ----------
 575    -- Hash --
 576    ----------
 577
 578    function Hash
 579      (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type
 580    is
 581       Buffer : Bounded_String (2052);
 582       IS_Nam : Name_Id;
 583
 584    begin
 585       --  The hash is obtained in the following manner:
 586       --
 587       --    * A String signature based on the scope, name, line number, column
 588       --      number, and locations, in the following format:
 589       --
 590       --         scope__name__line_column__locations
 591       --
 592       --    * The String is converted into a Name_Id
 593       --
 594       --    * The absolute value of the Name_Id is used as the hash
 595
 596       Append (Buffer, IS_Rec.Scope);
 597       Append (Buffer, "__");
 598       Append (Buffer, IS_Rec.Name);
 599       Append (Buffer, "__");
 600       Append (Buffer, IS_Rec.Line);
 601       Append (Buffer, '_');
 602       Append (Buffer, IS_Rec.Column);
 603
 604       if IS_Rec.Locations /= No_Name then
 605          Append (Buffer, "__");
 606          Append (Buffer, IS_Rec.Locations);
 607       end if;
 608
 609       IS_Nam := Name_Find (Buffer);
 610       return Bucket_Range_Type (abs IS_Nam);
 611    end Hash;
 612
 613    --------------------
 614    -- Initialize_ALI --
 615    --------------------
 616
 617    procedure Initialize_ALI is
 618    begin
 619       --  When (re)initializing ALI data structures the ALI user expects to
 620       --  get a fresh set of data structures. Thus we first need to erase the
 621       --  marks put in the name table by the previous set of ALI routine calls.
 622       --  These two loops are empty and harmless the first time in.
 623
 624       for J in ALIs.First .. ALIs.Last loop
 625          Set_Name_Table_Int (ALIs.Table (J).Afile, 0);
 626       end loop;
 627
 628       for J in Units.First .. Units.Last loop
 629          Set_Name_Table_Int (Units.Table (J).Uname, 0);
 630       end loop;
 631
 632       --  Free argument table strings
 633
 634       for J in Args.First .. Args.Last loop
 635          Free (Args.Table (J));
 636       end loop;
 637
 638       --  Initialize all tables
 639
 640       ALIs.Init;
 641       Invocation_Constructs.Init;
 642       Invocation_Relations.Init;
 643       Invocation_Signatures.Init;
 644       Linker_Options.Init;
 645       No_Deps.Init;
 646       Notes.Init;
 647       Sdep.Init;
 648       Units.Init;
 649       Version_Ref.Reset;
 650       Withs.Init;
 651       Xref_Entity.Init;
 652       Xref.Init;
 653       Xref_Section.Init;
 654
 655       --  Add dummy zeroth item in Linker_Options and Notes for sort calls
 656
 657       Linker_Options.Increment_Last;
 658       Notes.Increment_Last;
 659
 660       --  Initialize global variables recording cumulative options in all
 661       --  ALI files that are read for a given processing run in gnatbind.
 662
 663       Dynamic_Elaboration_Checks_Specified   := False;
 664       Locking_Policy_Specified               := ' ';
 665       No_Normalize_Scalars_Specified         := False;
 666       No_Object_Specified                    := False;
 667       No_Component_Reordering_Specified      := False;
 668       GNATprove_Mode_Specified               := False;
 669       Normalize_Scalars_Specified            := False;
 670       Partition_Elaboration_Policy_Specified := ' ';
 671       Queuing_Policy_Specified               := ' ';
 672       SSO_Default_Specified                  := False;
 673       Task_Dispatching_Policy_Specified      := ' ';
 674       Unreserve_All_Interrupts_Specified     := False;
 675       Frontend_Exceptions_Specified          := False;
 676       Zero_Cost_Exceptions_Specified         := False;
 677    end Initialize_ALI;
 678
 679    ---------------------------------------
 680    -- Invocation_Construct_Kind_To_Code --
 681    ---------------------------------------
 682
 683    function Invocation_Construct_Kind_To_Code
 684      (Kind : Invocation_Construct_Kind) return Character
 685    is
 686    begin
 687       return Invocation_Construct_Codes (Kind);
 688    end Invocation_Construct_Kind_To_Code;
 689
 690    -------------------------------
 691    -- Invocation_Graph_Encoding --
 692    -------------------------------
 693
 694    function Invocation_Graph_Encoding return Invocation_Graph_Encoding_Kind is
 695    begin
 696       return Compile_Time_Invocation_Graph_Encoding;
 697    end Invocation_Graph_Encoding;
 698
 699    --------------------------------------------
 700    -- Invocation_Graph_Encoding_Kind_To_Code --
 701    --------------------------------------------
 702
 703    function Invocation_Graph_Encoding_Kind_To_Code
 704      (Kind : Invocation_Graph_Encoding_Kind) return Character
 705    is
 706    begin
 707       return Invocation_Graph_Encoding_Codes (Kind);
 708    end Invocation_Graph_Encoding_Kind_To_Code;
 709
 710    ----------------------------------------
 711    -- Invocation_Graph_Line_Kind_To_Code --
 712    ----------------------------------------
 713
 714    function Invocation_Graph_Line_Kind_To_Code
 715      (Kind : Invocation_Graph_Line_Kind) return Character
 716    is
 717    begin
 718       return Invocation_Graph_Line_Codes (Kind);
 719    end Invocation_Graph_Line_Kind_To_Code;
 720
 721    -----------------------------
 722    -- Invocation_Kind_To_Code --
 723    -----------------------------
 724
 725    function Invocation_Kind_To_Code
 726      (Kind : Invocation_Kind) return Character
 727    is
 728    begin
 729       return Invocation_Codes (Kind);
 730    end Invocation_Kind_To_Code;
 731
 732    -----------------------------
 733    -- Invocation_Signature_Of --
 734    -----------------------------
 735
 736    function Invocation_Signature_Of
 737      (Column    : Nat;
 738       Line      : Nat;
 739       Locations : Name_Id;
 740       Name      : Name_Id;
 741       Scope     : Name_Id) return Invocation_Signature_Id
 742    is
 743       IS_Rec : constant Invocation_Signature_Record :=
 744                  (Column    => Column,
 745                   Line      => Line,
 746                   Locations => Locations,
 747                   Name      => Name,
 748                   Scope     => Scope);
 749       IS_Id  : Invocation_Signature_Id;
 750
 751    begin
 752       IS_Id := Sig_Map.Get (Sig_To_Sig_Map, IS_Rec);
 753
 754       --  The invocation signature lacks an id. This indicates that it
 755       --  is encountered for the first time during the construction of
 756       --  the graph.
 757
 758       if not Present (IS_Id) then
 759          Invocation_Signatures.Append (IS_Rec);
 760          IS_Id := Invocation_Signatures.Last;
 761
 762          --  Map the invocation signature record to its corresponding id
 763
 764          Sig_Map.Put (Sig_To_Sig_Map, IS_Rec, IS_Id);
 765       end if;
 766
 767       return IS_Id;
 768    end Invocation_Signature_Of;
 769
 770    -------------
 771    -- Invoker --
 772    -------------
 773
 774    function Invoker
 775      (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id
 776    is
 777    begin
 778       pragma Assert (Present (IR_Id));
 779       return Invocation_Relations.Table (IR_Id).Invoker;
 780    end Invoker;
 781
 782    ----------
 783    -- Kind --
 784    ----------
 785
 786    function Kind
 787      (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind
 788    is
 789    begin
 790       pragma Assert (Present (IC_Id));
 791       return Invocation_Constructs.Table (IC_Id).Kind;
 792    end Kind;
 793
 794    ----------
 795    -- Kind --
 796    ----------
 797
 798    function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind is
 799    begin
 800       pragma Assert (Present (IR_Id));
 801       return Invocation_Relations.Table (IR_Id).Kind;
 802    end Kind;
 803
 804    ----------
 805    -- Line --
 806    ----------
 807
 808    function Line (IS_Id : Invocation_Signature_Id) return Nat is
 809    begin
 810       pragma Assert (Present (IS_Id));
 811       return Invocation_Signatures.Table (IS_Id).Line;
 812    end Line;
 813
 814    ---------------
 815    -- Locations --
 816    ---------------
 817
 818    function Locations (IS_Id : Invocation_Signature_Id) return Name_Id is
 819    begin
 820       pragma Assert (Present (IS_Id));
 821       return Invocation_Signatures.Table (IS_Id).Locations;
 822    end Locations;
 823
 824    ----------
 825    -- Name --
 826    ----------
 827
 828    function Name (IS_Id : Invocation_Signature_Id) return Name_Id is
 829    begin
 830       pragma Assert (Present (IS_Id));
 831       return Invocation_Signatures.Table (IS_Id).Name;
 832    end Name;
 833
 834    -------------
 835    -- Present --
 836    -------------
 837
 838    function Present (IC_Id : Invocation_Construct_Id) return Boolean is
 839    begin
 840       return IC_Id /= No_Invocation_Construct;
 841    end Present;
 842
 843    -------------
 844    -- Present --
 845    -------------
 846
 847    function Present (IR_Id : Invocation_Relation_Id) return Boolean is
 848    begin
 849       return IR_Id /= No_Invocation_Relation;
 850    end Present;
 851
 852    -------------
 853    -- Present --
 854    -------------
 855
 856    function Present (IS_Id : Invocation_Signature_Id) return Boolean is
 857    begin
 858       return IS_Id /= No_Invocation_Signature;
 859    end Present;
 860
 861    -------------
 862    -- Present --
 863    -------------
 864
 865    function Present (Dep : Sdep_Id) return Boolean is
 866    begin
 867       return Dep /= No_Sdep_Id;
 868    end Present;
 869
 870    -------------
 871    -- Present --
 872    -------------
 873
 874    function Present (U_Id : Unit_Id) return Boolean is
 875    begin
 876       return U_Id /= No_Unit_Id;
 877    end Present;
 878
 879    -------------
 880    -- Present --
 881    -------------
 882
 883    function Present (W_Id : With_Id) return Boolean is
 884    begin
 885       return W_Id /= No_With_Id;
 886    end Present;
 887
 888    --------------
 889    -- Scan_ALI --
 890    --------------
 891
 892    function Scan_ALI
 893      (F                : File_Name_Type;
 894       T                : Text_Buffer_Ptr;
 895       Err              : Boolean;
 896       Ignore_Lines     : String  := "X";
 897       Ignore_Errors    : Boolean := False;
 898       Directly_Scanned : Boolean := False) return ALI_Id
 899    is
 900       P         : Text_Ptr            := T'First;
 901       Line      : Logical_Line_Number := 1;
 902       Id        : ALI_Id;
 903       C         : Character;
 904       NS_Found  : Boolean;
 905       First_Arg : Arg_Id;
 906
 907       Ignore : array (Character range 'A' .. 'Z') of Boolean :=
 908                  (others => False);
 909       --  Ignore (X) is set to True if lines starting with X are to
 910       --  be ignored by Scan_ALI and skipped, and False if the lines
 911       --  are to be read and processed.
 912
 913       Bad_ALI_Format : exception;
 914       --  Exception raised by Fatal_Error if Err is True
 915
 916       function At_Eol return Boolean;
 917       --  Test if at end of line
 918
 919       function At_End_Of_Field return Boolean;
 920       --  Test if at end of line, or if at blank or horizontal tab
 921
 922       procedure Check_At_End_Of_Field;
 923       --  Check if we are at end of field, fatal error if not
 924
 925       procedure Checkc (C : Character);
 926       --  Check next character is C. If so bump past it, if not fatal error
 927
 928       procedure Check_Unknown_Line;
 929       --  If Ignore_Errors mode, then checks C to make sure that it is not
 930       --  an unknown ALI line type characters, and if so, skips lines
 931       --  until the first character of the line is one of these characters,
 932       --  at which point it does a Getc to put that character in C. The
 933       --  call has no effect if C is already an appropriate character.
 934       --  If not in Ignore_Errors mode, a fatal error is signalled if the
 935       --  line is unknown. Note that if C is an EOL on entry, the line is
 936       --  skipped (it is assumed that blank lines are never significant).
 937       --  If C is EOF on entry, the call has no effect (it is assumed that
 938       --  the caller will properly handle this case).
 939
 940       procedure Fatal_Error;
 941       --  Generate fatal error message for badly formatted ALI file if
 942       --  Err is false, or raise Bad_ALI_Format if Err is True.
 943
 944       procedure Fatal_Error_Ignore;
 945       pragma Inline (Fatal_Error_Ignore);
 946       --  In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
 947
 948       function Getc return Character;
 949       --  Get next character, bumping P past the character obtained
 950
 951       function Get_File_Name
 952         (Lower         : Boolean := False;
 953          May_Be_Quoted : Boolean := False) return File_Name_Type;
 954       --  Skip blanks, then scan out a file name (name is left in Name_Buffer
 955       --  with length in Name_Len, as well as returning a File_Name_Type value.
 956       --  If May_Be_Quoted is True and the first non blank character is '"',
 957       --  then remove starting and ending quotes and undoubled internal quotes.
 958       --  If lower is false, the case is unchanged, if Lower is True then the
 959       --  result is forced to all lower case for systems where file names are
 960       --  not case sensitive. This ensures that gnatbind works correctly
 961       --  regardless of the case of the file name on all systems. The scan
 962       --  is terminated by a end of line, space or horizontal tab. Any other
 963       --  special characters are included in the returned name.
 964
 965       function Get_Name
 966         (Ignore_Special : Boolean := False;
 967          May_Be_Quoted  : Boolean := False) return Name_Id;
 968       --  Skip blanks, then scan out a name (name is left in Name_Buffer with
 969       --  length in Name_Len, as well as being returned in Name_Id form).
 970       --  If Lower is set to True then the Name_Buffer will be converted to
 971       --  all lower case, for systems where file names are not case sensitive.
 972       --  This ensures that gnatbind works correctly regardless of the case
 973       --  of the file name on all systems.
 974       --
 975       --  The scan is terminated by the normal end of field condition
 976       --  (EOL, space, horizontal tab). Furthermore, the termination condition
 977       --  depends on the setting of Ignore_Special:
 978       --
 979       --    If Ignore_Special is False (normal case), the scan is terminated by
 980       --    a typeref bracket or an equal sign except for the special case of
 981       --    an operator name starting with a double quote that is terminated
 982       --    by another double quote.
 983       --
 984       --    If May_Be_Quoted is True and the first non blank character is '"'
 985       --    the name is 'unquoted'. In this case Ignore_Special is ignored and
 986       --    assumed to be True.
 987       --
 988       --  This function handles wide characters properly.
 989
 990       function Get_Nat return Nat;
 991       --  Skip blanks, then scan out an unsigned integer value in Nat range
 992       --  raises ALI_Reading_Error if the encoutered type is not natural.
 993
 994       function Get_Stamp return Time_Stamp_Type;
 995       --  Skip blanks, then scan out a time stamp
 996
 997       function Get_Unit_Name return Unit_Name_Type;
 998       --  Skip blanks, then scan out a file name (name is left in Name_Buffer
 999       --  with length in Name_Len, as well as returning a Unit_Name_Type value.
1000       --  The case is unchanged and terminated by a normal end of field.
1001
1002       function Nextc return Character;
1003       --  Return current character without modifying pointer P
1004
1005       procedure Scan_Invocation_Graph_Line;
1006       --  Parse a single line that encodes a piece of the invocation graph
1007
1008       procedure Skip_Eol;
1009       --  Skip past spaces, then skip past end of line (fatal error if not
1010       --  at end of line). Also skips past any following blank lines.
1011
1012       procedure Skip_Line;
1013       --  Skip rest of current line and any following blank lines
1014
1015       procedure Skip_Space;
1016       --  Skip past white space (blanks or horizontal tab)
1017
1018       procedure Skipc;
1019       --  Skip past next character, does not affect value in C. This call
1020       --  is like calling Getc and ignoring the returned result.
1021
1022       ---------------------
1023       -- At_End_Of_Field --
1024       ---------------------
1025
1026       function At_End_Of_Field return Boolean is
1027       begin
1028          return Nextc <= ' ';
1029       end At_End_Of_Field;
1030
1031       ------------
1032       -- At_Eol --
1033       ------------
1034
1035       function At_Eol return Boolean is
1036       begin
1037          return Nextc = EOF or else Nextc = CR or else Nextc = LF;
1038       end At_Eol;
1039
1040       ---------------------------
1041       -- Check_At_End_Of_Field --
1042       ---------------------------
1043
1044       procedure Check_At_End_Of_Field is
1045       begin
1046          if not At_End_Of_Field then
1047             if Ignore_Errors then
1048                while Nextc > ' ' loop
1049                   P := P + 1;
1050                end loop;
1051             else
1052                Fatal_Error;
1053             end if;
1054          end if;
1055       end Check_At_End_Of_Field;
1056
1057       ------------------------
1058       -- Check_Unknown_Line --
1059       ------------------------
1060
1061       procedure Check_Unknown_Line is
1062       begin
1063          while C not in 'A' .. 'Z'
1064            or else not Known_ALI_Lines (C)
1065          loop
1066             if C = CR or else C = LF then
1067                Skip_Line;
1068                C := Nextc;
1069
1070             elsif C = EOF then
1071                return;
1072
1073             elsif Ignore_Errors then
1074                Skip_Line;
1075                C := Getc;
1076
1077             else
1078                Fatal_Error;
1079             end if;
1080          end loop;
1081       end Check_Unknown_Line;
1082
1083       ------------
1084       -- Checkc --
1085       ------------
1086
1087       procedure Checkc (C : Character) is
1088       begin
1089          if Nextc = C then
1090             P := P + 1;
1091          elsif Ignore_Errors then
1092             P := P + 1;
1093          else
1094             Fatal_Error;
1095          end if;
1096       end Checkc;
1097
1098       -----------------
1099       -- Fatal_Error --
1100       -----------------
1101
1102       procedure Fatal_Error is
1103          Ptr1 : Text_Ptr;
1104          Ptr2 : Text_Ptr;
1105          Col  : Int;
1106
1107          procedure Wchar (C : Character);
1108          --  Write a single character, replacing horizontal tab by spaces
1109
1110          procedure Wchar (C : Character) is
1111          begin
1112             if C = HT then
1113                loop
1114                   Wchar (' ');
1115                   exit when Col mod 8 = 0;
1116                end loop;
1117
1118             else
1119                Write_Char (C);
1120                Col := Col + 1;
1121             end if;
1122          end Wchar;
1123
1124       --  Start of processing for Fatal_Error
1125
1126       begin
1127          if Err then
1128             raise Bad_ALI_Format;
1129          end if;
1130
1131          Set_Standard_Error;
1132          Write_Str ("fatal error: file ");
1133          Write_Name (F);
1134          Write_Str (" is incorrectly formatted");
1135          Write_Eol;
1136
1137          Write_Str ("make sure you are using consistent versions " &
1138
1139          --  Split the following line so that it can easily be transformed for
1140          --  other back-ends where the compiler might have a different name.
1141
1142                     "of gcc/gnatbind");
1143
1144          Write_Eol;
1145
1146          --  Find start of line
1147
1148          Ptr1 := P;
1149          while Ptr1 > T'First
1150            and then T (Ptr1 - 1) /= CR
1151            and then T (Ptr1 - 1) /= LF
1152          loop
1153             Ptr1 := Ptr1 - 1;
1154          end loop;
1155
1156          Write_Int (Int (Line));
1157          Write_Str (". ");
1158
1159          if Line < 100 then
1160             Write_Char (' ');
1161          end if;
1162
1163          if Line < 10 then
1164             Write_Char (' ');
1165          end if;
1166
1167          Col := 0;
1168          Ptr2 := Ptr1;
1169
1170          while Ptr2 < T'Last
1171            and then T (Ptr2) /= CR
1172            and then T (Ptr2) /= LF
1173          loop
1174             Wchar (T (Ptr2));
1175             Ptr2 := Ptr2 + 1;
1176          end loop;
1177
1178          Write_Eol;
1179
1180          Write_Str ("     ");
1181          Col := 0;
1182
1183          while Ptr1 < P loop
1184             if T (Ptr1) = HT then
1185                Wchar (HT);
1186             else
1187                Wchar (' ');
1188             end if;
1189
1190             Ptr1 := Ptr1 + 1;
1191          end loop;
1192
1193          Wchar ('|');
1194          Write_Eol;
1195
1196          Exit_Program (E_Fatal);
1197       end Fatal_Error;
1198
1199       ------------------------
1200       -- Fatal_Error_Ignore --
1201       ------------------------
1202
1203       procedure Fatal_Error_Ignore is
1204       begin
1205          if not Ignore_Errors then
1206             Fatal_Error;
1207          end if;
1208       end Fatal_Error_Ignore;
1209
1210       -------------------
1211       -- Get_File_Name --
1212       -------------------
1213
1214       function Get_File_Name
1215         (Lower         : Boolean := False;
1216          May_Be_Quoted : Boolean := False) return File_Name_Type
1217       is
1218          F : Name_Id;
1219
1220       begin
1221          F := Get_Name (Ignore_Special => True,
1222                         May_Be_Quoted  => May_Be_Quoted);
1223
1224          --  Convert file name to all lower case if file names are not case
1225          --  sensitive. This ensures that we handle names in the canonical
1226          --  lower case format, regardless of the actual case.
1227
1228          if Lower and not File_Names_Case_Sensitive then
1229             Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1230             return Name_Find;
1231          else
1232             return File_Name_Type (F);
1233          end if;
1234       end Get_File_Name;
1235
1236       --------------
1237       -- Get_Name --
1238       --------------
1239
1240       function Get_Name
1241         (Ignore_Special : Boolean := False;
1242          May_Be_Quoted  : Boolean := False) return Name_Id
1243       is
1244          Char : Character;
1245
1246       begin
1247          Name_Len := 0;
1248          Skip_Space;
1249
1250          if At_Eol then
1251             if Ignore_Errors then
1252                return Error_Name;
1253             else
1254                Fatal_Error;
1255             end if;
1256          end if;
1257
1258          Char := Getc;
1259
1260          --  Deal with quoted characters
1261
1262          if May_Be_Quoted and then Char = '"' then
1263             loop
1264                if At_Eol then
1265                   if Ignore_Errors then
1266                      return Error_Name;
1267                   else
1268                      Fatal_Error;
1269                   end if;
1270                end if;
1271
1272                Char := Getc;
1273
1274                if Char = '"' then
1275                   if At_Eol then
1276                      exit;
1277
1278                   else
1279                      Char := Getc;
1280
1281                      if Char /= '"' then
1282                         P := P - 1;
1283                         exit;
1284                      end if;
1285                   end if;
1286                end if;
1287
1288                Add_Char_To_Name_Buffer (Char);
1289             end loop;
1290
1291          --  Other than case of quoted character
1292
1293          else
1294             P := P - 1;
1295             loop
1296                Add_Char_To_Name_Buffer (Getc);
1297
1298                exit when At_End_Of_Field;
1299
1300                if not Ignore_Special then
1301                   if Name_Buffer (1) = '"' then
1302                      exit when Name_Len > 1
1303                                and then Name_Buffer (Name_Len) = '"';
1304
1305                   else
1306                      --  Terminate on parens or angle brackets or equal sign
1307
1308                      exit when Nextc = '(' or else Nextc = ')'
1309                        or else Nextc = '{' or else Nextc = '}'
1310                        or else Nextc = '<' or else Nextc = '>'
1311                        or else Nextc = '=';
1312
1313                      --  Terminate on comma
1314
1315                      exit when Nextc = ',';
1316
1317                      --  Terminate if left bracket not part of wide char
1318                      --  sequence.
1319
1320                      exit when Nextc = '[' and then T (P + 1) /= '"';
1321
1322                      --  Terminate if right bracket not part of wide char
1323                      --  sequence.
1324
1325                      exit when Nextc = ']' and then T (P - 1) /= '"';
1326                   end if;
1327                end if;
1328             end loop;
1329          end if;
1330
1331          return Name_Find;
1332       end Get_Name;
1333
1334       -------------------
1335       -- Get_Unit_Name --
1336       -------------------
1337
1338       function Get_Unit_Name return Unit_Name_Type is
1339       begin
1340          return Unit_Name_Type (Get_Name);
1341       end Get_Unit_Name;
1342
1343       -------------
1344       -- Get_Nat --
1345       -------------
1346
1347       function Get_Nat return Nat is
1348          V : Nat;
1349
1350       begin
1351          Skip_Space;
1352
1353          --  Check if we are on a number. In the case of bad ALI files, this
1354          --  may not be true.
1355
1356          if not (Nextc in '0' .. '9') then
1357             Fatal_Error;
1358          end if;
1359
1360          V := 0;
1361          loop
1362             V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
1363
1364             exit when At_End_Of_Field;
1365             exit when Nextc < '0' or else Nextc > '9';
1366          end loop;
1367
1368          return V;
1369       end Get_Nat;
1370
1371       ---------------
1372       -- Get_Stamp --
1373       ---------------
1374
1375       function Get_Stamp return Time_Stamp_Type is
1376          T     : Time_Stamp_Type;
1377          Start : Integer;
1378
1379       begin
1380          Skip_Space;
1381
1382          if At_Eol then
1383             if Ignore_Errors then
1384                return Dummy_Time_Stamp;
1385             else
1386                Fatal_Error;
1387             end if;
1388          end if;
1389
1390          --  Following reads old style time stamp missing first two digits
1391
1392          if Nextc in '7' .. '9' then
1393             T (1) := '1';
1394             T (2) := '9';
1395             Start := 3;
1396
1397          --  Normal case of full year in time stamp
1398
1399          else
1400             Start := 1;
1401          end if;
1402
1403          for J in Start .. T'Last loop
1404             T (J) := Getc;
1405          end loop;
1406
1407          return T;
1408       end Get_Stamp;
1409
1410       ----------
1411       -- Getc --
1412       ----------
1413
1414       function Getc return Character is
1415       begin
1416          if P = T'Last then
1417             return EOF;
1418          else
1419             P := P + 1;
1420             return T (P - 1);
1421          end if;
1422       end Getc;
1423
1424       -----------
1425       -- Nextc --
1426       -----------
1427
1428       function Nextc return Character is
1429       begin
1430          return T (P);
1431       end Nextc;
1432
1433       --------------------------------
1434       -- Scan_Invocation_Graph_Line --
1435       --------------------------------
1436
1437       procedure Scan_Invocation_Graph_Line is
1438          procedure Scan_Invocation_Construct_Line;
1439          pragma Inline (Scan_Invocation_Construct_Line);
1440          --  Parse an invocation construct line and construct the corresponding
1441          --  construct. The following data structures are updated:
1442          --
1443          --    * Invocation_Constructs
1444          --    * Units
1445
1446          procedure Scan_Invocation_Graph_Attributes_Line;
1447          pragma Inline (Scan_Invocation_Graph_Attributes_Line);
1448          --  Parse an invocation-graph attributes line. The following data
1449          --  structures are updated:
1450          --
1451          --    * Units
1452
1453          procedure Scan_Invocation_Relation_Line;
1454          pragma Inline (Scan_Invocation_Relation_Line);
1455          --  Parse an invocation relation line and construct the corresponding
1456          --  relation. The following data structures are updated:
1457          --
1458          --    * Invocation_Relations
1459          --    * Units
1460
1461          function Scan_Invocation_Signature return Invocation_Signature_Id;
1462          pragma Inline (Scan_Invocation_Signature);
1463          --  Parse a single invocation signature while populating the following
1464          --  data structures:
1465          --
1466          --    * Invocation_Signatures
1467          --    * Sig_To_Sig_Map
1468
1469          ------------------------------------
1470          -- Scan_Invocation_Construct_Line --
1471          ------------------------------------
1472
1473          procedure Scan_Invocation_Construct_Line is
1474             Body_Placement : Declaration_Placement_Kind;
1475             Kind           : Invocation_Construct_Kind;
1476             Signature      : Invocation_Signature_Id;
1477             Spec_Placement : Declaration_Placement_Kind;
1478
1479          begin
1480             --  construct-kind
1481
1482             Kind := Code_To_Invocation_Construct_Kind (Getc);
1483             Checkc (' ');
1484             Skip_Space;
1485
1486             --  construct-spec-placement
1487
1488             Spec_Placement := Code_To_Declaration_Placement_Kind (Getc);
1489             Checkc (' ');
1490             Skip_Space;
1491
1492             --  construct-body-placement
1493
1494             Body_Placement := Code_To_Declaration_Placement_Kind (Getc);
1495             Checkc (' ');
1496             Skip_Space;
1497
1498             --  construct-signature
1499
1500             Signature := Scan_Invocation_Signature;
1501             Skip_Eol;
1502
1503             Add_Invocation_Construct
1504               (Body_Placement => Body_Placement,
1505                Kind           => Kind,
1506                Signature      => Signature,
1507                Spec_Placement => Spec_Placement);
1508          end Scan_Invocation_Construct_Line;
1509
1510          -------------------------------------------
1511          -- Scan_Invocation_Graph_Attributes_Line --
1512          -------------------------------------------
1513
1514          procedure Scan_Invocation_Graph_Attributes_Line is
1515          begin
1516             --  encoding-kind
1517
1518             Set_Invocation_Graph_Encoding
1519               (Code_To_Invocation_Graph_Encoding_Kind (Getc));
1520             Skip_Eol;
1521          end Scan_Invocation_Graph_Attributes_Line;
1522
1523          -----------------------------------
1524          -- Scan_Invocation_Relation_Line --
1525          -----------------------------------
1526
1527          procedure Scan_Invocation_Relation_Line is
1528             Extra   : Name_Id;
1529             Invoker : Invocation_Signature_Id;
1530             Kind    : Invocation_Kind;
1531             Target  : Invocation_Signature_Id;
1532
1533          begin
1534             --  relation-kind
1535
1536             Kind := Code_To_Invocation_Kind (Getc);
1537             Checkc (' ');
1538             Skip_Space;
1539
1540             --  (extra-name | "none")
1541
1542             Extra := Get_Name;
1543
1544             if Extra = Name_None then
1545                Extra := No_Name;
1546             end if;
1547
1548             Checkc (' ');
1549             Skip_Space;
1550
1551             --  invoker-signature
1552
1553             Invoker := Scan_Invocation_Signature;
1554             Checkc (' ');
1555             Skip_Space;
1556
1557             --  target-signature
1558
1559             Target := Scan_Invocation_Signature;
1560             Skip_Eol;
1561
1562             Add_Invocation_Relation
1563               (Extra   => Extra,
1564                Invoker => Invoker,
1565                Kind    => Kind,
1566                Target  => Target);
1567          end Scan_Invocation_Relation_Line;
1568
1569          -------------------------------
1570          -- Scan_Invocation_Signature --
1571          -------------------------------
1572
1573          function Scan_Invocation_Signature return Invocation_Signature_Id is
1574             Column    : Nat;
1575             Line      : Nat;
1576             Locations : Name_Id;
1577             Name      : Name_Id;
1578             Scope     : Name_Id;
1579
1580          begin
1581             --  [
1582
1583             Checkc ('[');
1584
1585             --  name
1586
1587             Name := Get_Name;
1588             Checkc (' ');
1589             Skip_Space;
1590
1591             --  scope
1592
1593             Scope := Get_Name;
1594             Checkc (' ');
1595             Skip_Space;
1596
1597             --  line
1598
1599             Line := Get_Nat;
1600             Checkc (' ');
1601             Skip_Space;
1602
1603             --  column
1604
1605             Column := Get_Nat;
1606             Checkc (' ');
1607             Skip_Space;
1608
1609             --  (locations | "none")
1610
1611             Locations := Get_Name;
1612
1613             if Locations = Name_None then
1614                Locations := No_Name;
1615             end if;
1616
1617             --  ]
1618
1619             Checkc (']');
1620
1621             --  Create an invocation signature from the scanned attributes
1622
1623             return
1624               Invocation_Signature_Of
1625                 (Column    => Column,
1626                  Line      => Line,
1627                  Locations => Locations,
1628                  Name      => Name,
1629                  Scope     => Scope);
1630          end Scan_Invocation_Signature;
1631
1632          --  Local variables
1633
1634          Line : Invocation_Graph_Line_Kind;
1635
1636       --  Start of processing for Scan_Invocation_Graph_Line
1637
1638       begin
1639          if Ignore ('G') then
1640             return;
1641          end if;
1642
1643          Checkc (' ');
1644          Skip_Space;
1645
1646          --  line-kind
1647
1648          Line := Code_To_Invocation_Graph_Line_Kind (Getc);
1649          Checkc (' ');
1650          Skip_Space;
1651
1652          --  line-attributes
1653
1654          case Line is
1655             when Invocation_Construct_Line =>
1656                Scan_Invocation_Construct_Line;
1657
1658             when Invocation_Graph_Attributes_Line =>
1659                Scan_Invocation_Graph_Attributes_Line;
1660
1661             when Invocation_Relation_Line =>
1662                Scan_Invocation_Relation_Line;
1663          end case;
1664       end Scan_Invocation_Graph_Line;
1665
1666       --------------
1667       -- Skip_Eol --
1668       --------------
1669
1670       procedure Skip_Eol is
1671       begin
1672          Skip_Space;
1673
1674          if not At_Eol then
1675             if Ignore_Errors then
1676                while not At_Eol loop
1677                   P := P + 1;
1678                end loop;
1679             else
1680                Fatal_Error;
1681             end if;
1682          end if;
1683
1684          --  Loop to skip past blank lines (first time through skips this EOL)
1685
1686          while Nextc < ' ' and then Nextc /= EOF loop
1687             if Nextc = LF then
1688                Line := Line + 1;
1689             end if;
1690
1691             P := P + 1;
1692          end loop;
1693       end Skip_Eol;
1694
1695       ---------------
1696       -- Skip_Line --
1697       ---------------
1698
1699       procedure Skip_Line is
1700       begin
1701          while not At_Eol loop
1702             P := P + 1;
1703          end loop;
1704
1705          Skip_Eol;
1706       end Skip_Line;
1707
1708       ----------------
1709       -- Skip_Space --
1710       ----------------
1711
1712       procedure Skip_Space is
1713       begin
1714          while Nextc = ' ' or else Nextc = HT loop
1715             P := P + 1;
1716          end loop;
1717       end Skip_Space;
1718
1719       -----------
1720       -- Skipc --
1721       -----------
1722
1723       procedure Skipc is
1724       begin
1725          if P /= T'Last then
1726             P := P + 1;
1727          end if;
1728       end Skipc;
1729
1730    --  Start of processing for Scan_ALI
1731
1732    begin
1733       First_Sdep_Entry := Sdep.Last + 1;
1734
1735       for J in Ignore_Lines'Range loop
1736          pragma Assert (Ignore_Lines (J) /= 'U');
1737          Ignore (Ignore_Lines (J)) := True;
1738       end loop;
1739
1740       --  Setup ALI Table entry with appropriate defaults
1741
1742       ALIs.Increment_Last;
1743       Id := ALIs.Last;
1744       Set_Name_Table_Int (F, Int (Id));
1745
1746       ALIs.Table (Id) := (
1747         Afile                        => F,
1748         Compile_Errors               => False,
1749         First_Interrupt_State        => Interrupt_States.Last + 1,
1750         First_Sdep                   => No_Sdep_Id,
1751         First_Specific_Dispatching   => Specific_Dispatching.Last + 1,
1752         First_Unit                   => No_Unit_Id,
1753         GNATprove_Mode               => False,
1754         Invocation_Graph_Encoding    => No_Encoding,
1755         Last_Interrupt_State         => Interrupt_States.Last,
1756         Last_Sdep                    => No_Sdep_Id,
1757         Last_Specific_Dispatching    => Specific_Dispatching.Last,
1758         Last_Unit                    => No_Unit_Id,
1759         Locking_Policy               => ' ',
1760         Main_Priority                => -1,
1761         Main_CPU                     => -1,
1762         Main_Program                 => None,
1763         No_Component_Reordering      => False,
1764         No_Object                    => False,
1765         Normalize_Scalars            => False,
1766         Ofile_Full_Name              => Full_Object_File_Name,
1767         Partition_Elaboration_Policy => ' ',
1768         Queuing_Policy               => ' ',
1769         Restrictions                 => No_Restrictions,
1770         SAL_Interface                => False,
1771         Sfile                        => No_File,
1772         SSO_Default                  => ' ',
1773         Task_Dispatching_Policy      => ' ',
1774         Time_Slice_Value             => -1,
1775         WC_Encoding                  => 'b',
1776         Unit_Exception_Table         => False,
1777         Ver                          => (others => ' '),
1778         Ver_Len                      => 0,
1779         Frontend_Exceptions          => False,
1780         Zero_Cost_Exceptions         => False);
1781
1782       --  Now we acquire the input lines from the ALI file. Note that the
1783       --  convention in the following code is that as we enter each section,
1784       --  C is set to contain the first character of the following line.
1785
1786       C := Getc;
1787       Check_Unknown_Line;
1788
1789       --  Acquire library version
1790
1791       if C /= 'V' then
1792
1793          --  The V line missing really indicates trouble, most likely it
1794          --  means we don't have an ALI file at all, so here we give a
1795          --  fatal error even if we are in Ignore_Errors mode.
1796
1797          Fatal_Error;
1798
1799       elsif Ignore ('V') then
1800          Skip_Line;
1801
1802       else
1803          Checkc (' ');
1804          Skip_Space;
1805          Checkc ('"');
1806
1807          for J in 1 .. Ver_Len_Max loop
1808             C := Getc;
1809             exit when C = '"';
1810             ALIs.Table (Id).Ver (J) := C;
1811             ALIs.Table (Id).Ver_Len := J;
1812          end loop;
1813
1814          Skip_Eol;
1815       end if;
1816
1817       C := Getc;
1818       Check_Unknown_Line;
1819
1820       --  Acquire main program line if present
1821
1822       if C = 'M' then
1823          if Ignore ('M') then
1824             Skip_Line;
1825
1826          else
1827             Checkc (' ');
1828             Skip_Space;
1829
1830             C := Getc;
1831
1832             if C = 'F' then
1833                ALIs.Table (Id).Main_Program := Func;
1834             elsif C = 'P' then
1835                ALIs.Table (Id).Main_Program := Proc;
1836             else
1837                P := P - 1;
1838                Fatal_Error;
1839             end if;
1840
1841             Skip_Space;
1842
1843             if not At_Eol then
1844                if Nextc < 'A' then
1845                   ALIs.Table (Id).Main_Priority := Get_Nat;
1846                end if;
1847
1848                Skip_Space;
1849
1850                if Nextc = 'T' then
1851                   P := P + 1;
1852                   Checkc ('=');
1853                   ALIs.Table (Id).Time_Slice_Value := Get_Nat;
1854                end if;
1855
1856                Skip_Space;
1857
1858                if Nextc = 'C' then
1859                   P := P + 1;
1860                   Checkc ('=');
1861                   ALIs.Table (Id).Main_CPU := Get_Nat;
1862                end if;
1863
1864                Skip_Space;
1865
1866                Checkc ('W');
1867                Checkc ('=');
1868                ALIs.Table (Id).WC_Encoding := Getc;
1869             end if;
1870
1871             Skip_Eol;
1872          end if;
1873
1874          C := Getc;
1875       end if;
1876
1877       --  Acquire argument lines
1878
1879       First_Arg := Args.Last + 1;
1880
1881       A_Loop : loop
1882          Check_Unknown_Line;
1883          exit A_Loop when C /= 'A';
1884
1885          if Ignore ('A') then
1886             Skip_Line;
1887
1888          else
1889             Checkc (' ');
1890
1891             --  Scan out argument
1892
1893             Name_Len := 0;
1894             while not At_Eol loop
1895                Add_Char_To_Name_Buffer (Getc);
1896             end loop;
1897
1898             --  If -fstack-check, record that it occurred. Note that an
1899             --  additional string parameter can be specified, in the form of
1900             --  -fstack-check={no|generic|specific}. "no" means no checking,
1901             --  "generic" means force the use of old-style checking, and
1902             --  "specific" means use the best checking method.
1903
1904             if Name_Len >= 13
1905               and then Name_Buffer (1 .. 13) = "-fstack-check"
1906               and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no"
1907             then
1908                Stack_Check_Switch_Set := True;
1909             end if;
1910
1911             --  Store the argument
1912
1913             Args.Increment_Last;
1914             Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
1915
1916             Skip_Eol;
1917          end if;
1918
1919          C := Getc;
1920       end loop A_Loop;
1921
1922       --  Acquire P line
1923
1924       Check_Unknown_Line;
1925
1926       while C /= 'P' loop
1927          if Ignore_Errors then
1928             if C = EOF then
1929                Fatal_Error;
1930             else
1931                Skip_Line;
1932                C := Nextc;
1933             end if;
1934          else
1935             Fatal_Error;
1936          end if;
1937       end loop;
1938
1939       if Ignore ('P') then
1940          Skip_Line;
1941
1942       --  Process P line
1943
1944       else
1945          NS_Found := False;
1946
1947          while not At_Eol loop
1948             Checkc (' ');
1949             Skip_Space;
1950             C := Getc;
1951
1952             --  Processing for CE
1953
1954             if C = 'C' then
1955                Checkc ('E');
1956                ALIs.Table (Id).Compile_Errors := True;
1957
1958             --  Processing for DB
1959
1960             elsif C = 'D' then
1961                Checkc ('B');
1962                Detect_Blocking := True;
1963
1964             --  Processing for Ex
1965
1966             elsif C = 'E' then
1967                Partition_Elaboration_Policy_Specified := Getc;
1968                ALIs.Table (Id).Partition_Elaboration_Policy :=
1969                  Partition_Elaboration_Policy_Specified;
1970
1971             --  Processing for FX
1972
1973             elsif C = 'F' then
1974                C := Getc;
1975
1976                if C = 'X' then
1977                   ALIs.Table (Id).Frontend_Exceptions := True;
1978                   Frontend_Exceptions_Specified := True;
1979                else
1980                   Fatal_Error_Ignore;
1981                end if;
1982
1983             --  Processing for GP
1984
1985             elsif C = 'G' then
1986                Checkc ('P');
1987                GNATprove_Mode_Specified := True;
1988                ALIs.Table (Id).GNATprove_Mode := True;
1989
1990             --  Processing for Lx
1991
1992             elsif C = 'L' then
1993                Locking_Policy_Specified := Getc;
1994                ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
1995
1996             --  Processing for flags starting with N
1997
1998             elsif C = 'N' then
1999                C := Getc;
2000
2001                --  Processing for NC
2002
2003                if C = 'C' then
2004                   ALIs.Table (Id).No_Component_Reordering := True;
2005                   No_Component_Reordering_Specified := True;
2006
2007                --  Processing for NO
2008
2009                elsif C = 'O' then
2010                   ALIs.Table (Id).No_Object := True;
2011                   No_Object_Specified := True;
2012
2013                --  Processing for NR
2014
2015                elsif C = 'R' then
2016                   No_Run_Time_Mode           := True;
2017                   Configurable_Run_Time_Mode := True;
2018
2019                --  Processing for NS
2020
2021                elsif C = 'S' then
2022                   ALIs.Table (Id).Normalize_Scalars := True;
2023                   Normalize_Scalars_Specified := True;
2024                   NS_Found := True;
2025
2026                --  Invalid switch starting with N
2027
2028                else
2029                   Fatal_Error_Ignore;
2030                end if;
2031
2032             --  Processing for OH/OL
2033
2034             elsif C = 'O' then
2035                C := Getc;
2036
2037                if C = 'L' or else C = 'H' then
2038                   ALIs.Table (Id).SSO_Default := C;
2039                   SSO_Default_Specified := True;
2040
2041                else
2042                   Fatal_Error_Ignore;
2043                end if;
2044
2045             --  Processing for Qx
2046
2047             elsif C = 'Q' then
2048                Queuing_Policy_Specified := Getc;
2049                ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
2050
2051             --  Processing for flags starting with S
2052
2053             elsif C = 'S' then
2054                C := Getc;
2055
2056                --  Processing for SL
2057
2058                if C = 'L' then
2059                   ALIs.Table (Id).SAL_Interface := True;
2060
2061                --  Processing for SS
2062
2063                elsif C = 'S' then
2064                   Opt.Sec_Stack_Used := True;
2065
2066                --  Invalid switch starting with S
2067
2068                else
2069                   Fatal_Error_Ignore;
2070                end if;
2071
2072             --  Processing for Tx
2073
2074             elsif C = 'T' then
2075                Task_Dispatching_Policy_Specified := Getc;
2076                ALIs.Table (Id).Task_Dispatching_Policy :=
2077                  Task_Dispatching_Policy_Specified;
2078
2079             --  Processing for switch starting with U
2080
2081             elsif C = 'U' then
2082                C := Getc;
2083
2084                --  Processing for UA
2085
2086                if C  = 'A' then
2087                   Unreserve_All_Interrupts_Specified := True;
2088
2089                --  Processing for UX
2090
2091                elsif C = 'X' then
2092                   ALIs.Table (Id).Unit_Exception_Table := True;
2093
2094                --  Invalid switches starting with U
2095
2096                else
2097                   Fatal_Error_Ignore;
2098                end if;
2099
2100             --  Processing for ZX
2101
2102             elsif C = 'Z' then
2103                C := Getc;
2104
2105                if C = 'X' then
2106                   ALIs.Table (Id).Zero_Cost_Exceptions := True;
2107                   Zero_Cost_Exceptions_Specified := True;
2108                else
2109                   Fatal_Error_Ignore;
2110                end if;
2111
2112             --  Invalid parameter
2113
2114             else
2115                C := Getc;
2116                Fatal_Error_Ignore;
2117             end if;
2118          end loop;
2119
2120          if not NS_Found then
2121             No_Normalize_Scalars_Specified := True;
2122          end if;
2123
2124          Skip_Eol;
2125       end if;
2126
2127       C := Getc;
2128       Check_Unknown_Line;
2129
2130       --  Loop to skip to first restrictions line
2131
2132       while C /= 'R' loop
2133          if Ignore_Errors then
2134             if C = EOF then
2135                Fatal_Error;
2136             else
2137                Skip_Line;
2138                C := Nextc;
2139             end if;
2140          else
2141             Fatal_Error;
2142          end if;
2143       end loop;
2144
2145       --  Ignore all 'R' lines if that is required
2146
2147       if Ignore ('R') then
2148          while C = 'R' loop
2149             Skip_Line;
2150             C := Getc;
2151          end loop;
2152
2153       --  Here we process the restrictions lines (other than unit name cases)
2154
2155       else
2156          Scan_Restrictions : declare
2157             Save_R : constant Restrictions_Info := Cumulative_Restrictions;
2158             --  Save cumulative restrictions in case we have a fatal error
2159
2160             Bad_R_Line : exception;
2161             --  Signal bad restrictions line (raised on unexpected character)
2162
2163             Typ : Character;
2164             R   : Restriction_Id;
2165             N   : Natural;
2166
2167          begin
2168             --  Named restriction case
2169
2170             if Nextc = 'N' then
2171                Skip_Line;
2172                C := Getc;
2173
2174                --  Loop through RR and RV lines
2175
2176                while C = 'R' and then Nextc /= ' ' loop
2177                   Typ := Getc;
2178                   Checkc (' ');
2179
2180                   --  Acquire restriction name
2181
2182                   Name_Len := 0;
2183                   while not At_Eol and then Nextc /= '=' loop
2184                      Name_Len := Name_Len + 1;
2185                      Name_Buffer (Name_Len) := Getc;
2186                   end loop;
2187
2188                   --  Now search list of restrictions to find match
2189
2190                   declare
2191                      RN : String renames Name_Buffer (1 .. Name_Len);
2192
2193                   begin
2194                      R := Restriction_Id'First;
2195                      while R /= Not_A_Restriction_Id loop
2196                         if Restriction_Id'Image (R) = RN then
2197                            goto R_Found;
2198                         end if;
2199
2200                         R := Restriction_Id'Succ (R);
2201                      end loop;
2202
2203                      --  We don't recognize the restriction. This might be
2204                      --  thought of as an error, and it really is, but we
2205                      --  want to allow building with inconsistent versions
2206                      --  of the binder and ali files (see comments at the
2207                      --  start of package System.Rident), so we just ignore
2208                      --  this situation.
2209
2210                      goto Done_With_Restriction_Line;
2211                   end;
2212
2213                   <<R_Found>>
2214
2215                   case R is
2216
2217                      --  Boolean restriction case
2218
2219                      when All_Boolean_Restrictions =>
2220                         case Typ is
2221                            when 'V' =>
2222                               ALIs.Table (Id).Restrictions.Violated (R) :=
2223                                 True;
2224                               Cumulative_Restrictions.Violated (R) := True;
2225
2226                            when 'R' =>
2227                               ALIs.Table (Id).Restrictions.Set (R) := True;
2228                               Cumulative_Restrictions.Set (R) := True;
2229
2230                            when others =>
2231                               raise Bad_R_Line;
2232                         end case;
2233
2234                      --  Parameter restriction case
2235
2236                      when All_Parameter_Restrictions =>
2237                         if At_Eol or else Nextc /= '=' then
2238                            raise Bad_R_Line;
2239                         else
2240                            Skipc;
2241                         end if;
2242
2243                         N := Natural (Get_Nat);
2244
2245                         case Typ is
2246
2247                            --  Restriction set
2248
2249                            when 'R' =>
2250                               ALIs.Table (Id).Restrictions.Set (R) := True;
2251                               ALIs.Table (Id).Restrictions.Value (R) := N;
2252
2253                               if Cumulative_Restrictions.Set (R) then
2254                                  Cumulative_Restrictions.Value (R) :=
2255                                    Integer'Min
2256                                      (Cumulative_Restrictions.Value (R), N);
2257                               else
2258                                  Cumulative_Restrictions.Set (R) := True;
2259                                  Cumulative_Restrictions.Value (R) := N;
2260                               end if;
2261
2262                            --  Restriction violated
2263
2264                            when 'V' =>
2265                               ALIs.Table (Id).Restrictions.Violated (R) :=
2266                                 True;
2267                               Cumulative_Restrictions.Violated (R) := True;
2268                               ALIs.Table (Id).Restrictions.Count (R) := N;
2269
2270                               --  Checked Max_Parameter case
2271
2272                               if R in Checked_Max_Parameter_Restrictions then
2273                                  Cumulative_Restrictions.Count (R) :=
2274                                    Integer'Max
2275                                      (Cumulative_Restrictions.Count (R), N);
2276
2277                               --  Other checked parameter cases
2278
2279                               else
2280                                  declare
2281                                     pragma Unsuppress (Overflow_Check);
2282
2283                                  begin
2284                                     Cumulative_Restrictions.Count (R) :=
2285                                       Cumulative_Restrictions.Count (R) + N;
2286
2287                                  exception
2288                                     when Constraint_Error =>
2289
2290                                        --  A constraint error comes from the
2291                                        --  addition. We reset to the maximum
2292                                        --  and indicate that the real value
2293                                        --  is now unknown.
2294
2295                                        Cumulative_Restrictions.Value (R) :=
2296                                          Integer'Last;
2297                                        Cumulative_Restrictions.Unknown (R) :=
2298                                          True;
2299                                  end;
2300                               end if;
2301
2302                               --  Deal with + case
2303
2304                               if Nextc = '+' then
2305                                  Skipc;
2306                                  ALIs.Table (Id).Restrictions.Unknown (R) :=
2307                                    True;
2308                                  Cumulative_Restrictions.Unknown (R) := True;
2309                               end if;
2310
2311                            --  Other than 'R' or 'V'
2312
2313                            when others =>
2314                               raise Bad_R_Line;
2315                         end case;
2316
2317                         if not At_Eol then
2318                            raise Bad_R_Line;
2319                         end if;
2320
2321                      --  Bizarre error case NOT_A_RESTRICTION
2322
2323                      when Not_A_Restriction_Id =>
2324                         raise Bad_R_Line;
2325                   end case;
2326
2327                   if not At_Eol then
2328                      raise Bad_R_Line;
2329                   end if;
2330
2331                <<Done_With_Restriction_Line>>
2332                   Skip_Line;
2333                   C := Getc;
2334                end loop;
2335
2336             --  Positional restriction case
2337
2338             else
2339                Checkc (' ');
2340                Skip_Space;
2341
2342                --  Acquire information for boolean restrictions
2343
2344                for R in All_Boolean_Restrictions loop
2345                   C := Getc;
2346
2347                   case C is
2348                      when 'v' =>
2349                         ALIs.Table (Id).Restrictions.Violated (R) := True;
2350                         Cumulative_Restrictions.Violated (R) := True;
2351
2352                      when 'r' =>
2353                         ALIs.Table (Id).Restrictions.Set (R) := True;
2354                         Cumulative_Restrictions.Set (R) := True;
2355
2356                      when 'n' =>
2357                         null;
2358
2359                      when others =>
2360                         raise Bad_R_Line;
2361                   end case;
2362                end loop;
2363
2364                --  Acquire information for parameter restrictions
2365
2366                for RP in All_Parameter_Restrictions loop
2367                   case Getc is
2368                      when 'n' =>
2369                         null;
2370
2371                      when 'r' =>
2372                         ALIs.Table (Id).Restrictions.Set (RP) := True;
2373
2374                         declare
2375                            N : constant Integer := Integer (Get_Nat);
2376                         begin
2377                            ALIs.Table (Id).Restrictions.Value (RP) := N;
2378
2379                            if Cumulative_Restrictions.Set (RP) then
2380                               Cumulative_Restrictions.Value (RP) :=
2381                                 Integer'Min
2382                                   (Cumulative_Restrictions.Value (RP), N);
2383                            else
2384                               Cumulative_Restrictions.Set (RP) := True;
2385                               Cumulative_Restrictions.Value (RP) := N;
2386                            end if;
2387                         end;
2388
2389                      when others =>
2390                         raise Bad_R_Line;
2391                   end case;
2392
2393                   --  Acquire restrictions violations information
2394
2395                   case Getc is
2396
2397                   when 'n' =>
2398                      null;
2399
2400                   when 'v' =>
2401                      ALIs.Table (Id).Restrictions.Violated (RP) := True;
2402                      Cumulative_Restrictions.Violated (RP) := True;
2403
2404                      declare
2405                         N : constant Integer := Integer (Get_Nat);
2406
2407                      begin
2408                         ALIs.Table (Id).Restrictions.Count (RP) := N;
2409
2410                         if RP in Checked_Max_Parameter_Restrictions then
2411                            Cumulative_Restrictions.Count (RP) :=
2412                              Integer'Max
2413                                (Cumulative_Restrictions.Count (RP), N);
2414
2415                         else
2416                            declare
2417                               pragma Unsuppress (Overflow_Check);
2418
2419                            begin
2420                               Cumulative_Restrictions.Count (RP) :=
2421                                 Cumulative_Restrictions.Count (RP) + N;
2422
2423                            exception
2424                               when Constraint_Error =>
2425
2426                                  --  A constraint error comes from the add. We
2427                                  --  reset to the maximum and indicate that the
2428                                  --  real value is now unknown.
2429
2430                                  Cumulative_Restrictions.Value (RP) :=
2431                                    Integer'Last;
2432                                  Cumulative_Restrictions.Unknown (RP) := True;
2433                            end;
2434                         end if;
2435
2436                         if Nextc = '+' then
2437                            Skipc;
2438                            ALIs.Table (Id).Restrictions.Unknown (RP) := True;
2439                            Cumulative_Restrictions.Unknown (RP) := True;
2440                         end if;
2441                      end;
2442
2443                   when others =>
2444                      raise Bad_R_Line;
2445                   end case;
2446                end loop;
2447
2448                if not At_Eol then
2449                   raise Bad_R_Line;
2450                else
2451                   Skip_Line;
2452                   C := Getc;
2453                end if;
2454             end if;
2455
2456          --  Here if error during scanning of restrictions line
2457
2458          exception
2459             when Bad_R_Line =>
2460
2461                --  In Ignore_Errors mode, undo any changes to restrictions
2462                --  from this unit, and continue on, skipping remaining R
2463                --  lines for this unit.
2464
2465                if Ignore_Errors then
2466                   Cumulative_Restrictions := Save_R;
2467                   ALIs.Table (Id).Restrictions := No_Restrictions;
2468
2469                   loop
2470                      Skip_Eol;
2471                      C := Getc;
2472                      exit when C /= 'R';
2473                   end loop;
2474
2475                --  In normal mode, this is a fatal error
2476
2477                else
2478                   Fatal_Error;
2479                end if;
2480          end Scan_Restrictions;
2481       end if;
2482
2483       --  Acquire additional restrictions (No_Dependence) lines if present
2484
2485       while C = 'R' loop
2486          if Ignore ('R') then
2487             Skip_Line;
2488          else
2489             Skip_Space;
2490             No_Deps.Append ((Id, Get_Name));
2491             Skip_Eol;
2492          end if;
2493
2494          C := Getc;
2495       end loop;
2496
2497       --  Acquire 'I' lines if present
2498
2499       Check_Unknown_Line;
2500
2501       while C = 'I' loop
2502          if Ignore ('I') then
2503             Skip_Line;
2504
2505          else
2506             declare
2507                Int_Num : Nat;
2508                I_State : Character;
2509                Line_No : Nat;
2510
2511             begin
2512                Int_Num := Get_Nat;
2513                Skip_Space;
2514                I_State := Getc;
2515                Line_No := Get_Nat;
2516
2517                Interrupt_States.Append (
2518                  (Interrupt_Id    => Int_Num,
2519                   Interrupt_State => I_State,
2520                   IS_Pragma_Line  => Line_No));
2521
2522                ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
2523                Skip_Eol;
2524             end;
2525          end if;
2526
2527          C := Getc;
2528       end loop;
2529
2530       --  Acquire 'S' lines if present
2531
2532       Check_Unknown_Line;
2533
2534       while C = 'S' loop
2535          if Ignore ('S') then
2536             Skip_Line;
2537
2538          else
2539             declare
2540                Policy     : Character;
2541                First_Prio : Nat;
2542                Last_Prio  : Nat;
2543                Line_No    : Nat;
2544
2545             begin
2546                Checkc (' ');
2547                Skip_Space;
2548
2549                Policy := Getc;
2550                Skip_Space;
2551                First_Prio := Get_Nat;
2552                Last_Prio := Get_Nat;
2553                Line_No := Get_Nat;
2554
2555                Specific_Dispatching.Append (
2556                  (Dispatching_Policy => Policy,
2557                   First_Priority     => First_Prio,
2558                   Last_Priority      => Last_Prio,
2559                   PSD_Pragma_Line    => Line_No));
2560
2561                ALIs.Table (Id).Last_Specific_Dispatching :=
2562                  Specific_Dispatching.Last;
2563
2564                Skip_Eol;
2565             end;
2566          end if;
2567
2568          C := Getc;
2569       end loop;
2570
2571       --  Loop to acquire unit entries
2572
2573       U_Loop : loop
2574          Check_Unknown_Line;
2575          exit U_Loop when C /= 'U';
2576
2577          --  Note: as per spec, we never ignore U lines
2578
2579          Checkc (' ');
2580          Skip_Space;
2581          Units.Increment_Last;
2582
2583          if ALIs.Table (Id).First_Unit = No_Unit_Id then
2584             ALIs.Table (Id).First_Unit := Units.Last;
2585          end if;
2586
2587          declare
2588             UL : Unit_Record renames Units.Table (Units.Last);
2589
2590          begin
2591             UL.Uname                      := Get_Unit_Name;
2592             UL.Predefined                 := Is_Predefined_Unit;
2593             UL.Internal                   := Is_Internal_Unit;
2594             UL.My_ALI                     := Id;
2595             UL.Sfile                      := Get_File_Name (Lower => True);
2596             UL.Pure                       := False;
2597             UL.Preelab                    := False;
2598             UL.No_Elab                    := False;
2599             UL.Shared_Passive             := False;
2600             UL.RCI                        := False;
2601             UL.Remote_Types               := False;
2602             UL.Serious_Errors             := False;
2603             UL.Has_RACW                   := False;
2604             UL.Init_Scalars               := False;
2605             UL.Is_Generic                 := False;
2606             UL.Icasing                    := Mixed_Case;
2607             UL.Kcasing                    := All_Lower_Case;
2608             UL.Dynamic_Elab               := False;
2609             UL.Elaborate_Body             := False;
2610             UL.Set_Elab_Entity            := False;
2611             UL.Version                    := "00000000";
2612             UL.First_With                 := Withs.Last + 1;
2613             UL.First_Arg                  := First_Arg;
2614             UL.First_Invocation_Construct := Invocation_Constructs.Last + 1;
2615             UL.Last_Invocation_Construct  := No_Invocation_Construct;
2616             UL.First_Invocation_Relation  := Invocation_Relations.Last + 1;
2617             UL.Last_Invocation_Relation   := No_Invocation_Relation;
2618             UL.Elab_Position              := 0;
2619             UL.SAL_Interface              := ALIs.Table (Id).SAL_Interface;
2620             UL.Directly_Scanned           := Directly_Scanned;
2621             UL.Body_Needed_For_SAL        := False;
2622             UL.Elaborate_Body_Desirable   := False;
2623             UL.Optimize_Alignment         := 'O';
2624             UL.Has_Finalizer              := False;
2625             UL.Primary_Stack_Count        := 0;
2626             UL.Sec_Stack_Count            := 0;
2627
2628             if Debug_Flag_U then
2629                Write_Str (" ----> reading unit ");
2630                Write_Int (Int (Units.Last));
2631                Write_Str ("  ");
2632                Write_Unit_Name (UL.Uname);
2633                Write_Str (" from file ");
2634                Write_Name (UL.Sfile);
2635                Write_Eol;
2636             end if;
2637          end;
2638
2639          --  Check for duplicated unit in different files
2640
2641          declare
2642             Info : constant Int := Get_Name_Table_Int
2643                                      (Units.Table (Units.Last).Uname);
2644          begin
2645             if Info /= 0
2646               and then Units.Table (Units.Last).Sfile /=
2647                        Units.Table (Unit_Id (Info)).Sfile
2648             then
2649                --  If Err is set then ignore duplicate unit name. This is the
2650                --  case of a call from gnatmake, where the situation can arise
2651                --  from substitution of source files. In such situations, the
2652                --  processing in gnatmake will always result in any required
2653                --  recompilations in any case, and if we consider this to be
2654                --  an error we get strange cases (for example when a generic
2655                --  instantiation is replaced by a normal package) where we
2656                --  read the old ali file, decide to recompile, and then decide
2657                --  that the old and new ali files are incompatible.
2658
2659                if Err then
2660                   null;
2661
2662                --  If Err is not set, then this is a fatal error. This is
2663                --  the case of being called from the binder, where we must
2664                --  definitely diagnose this as an error.
2665
2666                else
2667                   Set_Standard_Error;
2668                   Write_Str ("error: duplicate unit name: ");
2669                   Write_Eol;
2670
2671                   Write_Str ("error: unit """);
2672                   Write_Unit_Name (Units.Table (Units.Last).Uname);
2673                   Write_Str (""" found in file """);
2674                   Write_Name_Decoded (Units.Table (Units.Last).Sfile);
2675                   Write_Char ('"');
2676                   Write_Eol;
2677
2678                   Write_Str ("error: unit """);
2679                   Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
2680                   Write_Str (""" found in file """);
2681                   Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
2682                   Write_Char ('"');
2683                   Write_Eol;
2684
2685                   Exit_Program (E_Fatal);
2686                end if;
2687             end if;
2688          end;
2689
2690          Set_Name_Table_Int
2691            (Units.Table (Units.Last).Uname, Int (Units.Last));
2692
2693          --  Scan out possible version and other parameters
2694
2695          loop
2696             Skip_Space;
2697             exit when At_Eol;
2698             C := Getc;
2699
2700             --  Version field
2701
2702             if C in '0' .. '9' or else C in 'a' .. 'f' then
2703                Units.Table (Units.Last).Version (1) := C;
2704
2705                for J in 2 .. 8 loop
2706                   C := Getc;
2707                   Units.Table (Units.Last).Version (J) := C;
2708                end loop;
2709
2710             --  BD/BN parameters
2711
2712             elsif C = 'B' then
2713                C := Getc;
2714
2715                if C = 'D' then
2716                   Check_At_End_Of_Field;
2717                   Units.Table (Units.Last).Elaborate_Body_Desirable := True;
2718
2719                elsif C = 'N' then
2720                   Check_At_End_Of_Field;
2721                   Units.Table (Units.Last).Body_Needed_For_SAL := True;
2722
2723                else
2724                   Fatal_Error_Ignore;
2725                end if;
2726
2727             --  DE parameter (Dynamic elaboration checks)
2728
2729             elsif C = 'D' then
2730                C := Getc;
2731
2732                if C = 'E' then
2733                   Check_At_End_Of_Field;
2734                   Units.Table (Units.Last).Dynamic_Elab := True;
2735                   Dynamic_Elaboration_Checks_Specified := True;
2736                else
2737                   Fatal_Error_Ignore;
2738                end if;
2739
2740             --  EB/EE parameters
2741
2742             elsif C = 'E' then
2743                C := Getc;
2744
2745                if C = 'B' then
2746                   Units.Table (Units.Last).Elaborate_Body := True;
2747                elsif C = 'E' then
2748                   Units.Table (Units.Last).Set_Elab_Entity := True;
2749                else
2750                   Fatal_Error_Ignore;
2751                end if;
2752
2753                Check_At_End_Of_Field;
2754
2755             --  GE parameter (generic)
2756
2757             elsif C = 'G' then
2758                C := Getc;
2759
2760                if C = 'E' then
2761                   Check_At_End_Of_Field;
2762                   Units.Table (Units.Last).Is_Generic := True;
2763                else
2764                   Fatal_Error_Ignore;
2765                end if;
2766
2767             --  IL/IS/IU parameters
2768
2769             elsif C = 'I' then
2770                C := Getc;
2771
2772                if C = 'L' then
2773                   Units.Table (Units.Last).Icasing := All_Lower_Case;
2774                elsif C = 'S' then
2775                   Units.Table (Units.Last).Init_Scalars := True;
2776                   Initialize_Scalars_Used := True;
2777                elsif C = 'U' then
2778                   Units.Table (Units.Last).Icasing := All_Upper_Case;
2779                else
2780                   Fatal_Error_Ignore;
2781                end if;
2782
2783                Check_At_End_Of_Field;
2784
2785             --  KM/KU parameters
2786
2787             elsif C = 'K' then
2788                C := Getc;
2789
2790                if C = 'M' then
2791                   Units.Table (Units.Last).Kcasing := Mixed_Case;
2792                elsif C = 'U' then
2793                   Units.Table (Units.Last).Kcasing := All_Upper_Case;
2794                else
2795                   Fatal_Error_Ignore;
2796                end if;
2797
2798                Check_At_End_Of_Field;
2799
2800             --  NE parameter
2801
2802             elsif C = 'N' then
2803                C := Getc;
2804
2805                if C = 'E' then
2806                   Units.Table (Units.Last).No_Elab := True;
2807                   Check_At_End_Of_Field;
2808                else
2809                   Fatal_Error_Ignore;
2810                end if;
2811
2812             --  PF/PR/PU/PK parameters
2813
2814             elsif C = 'P' then
2815                C := Getc;
2816
2817                if C = 'F' then
2818                   Units.Table (Units.Last).Has_Finalizer := True;
2819                elsif C = 'R' then
2820                   Units.Table (Units.Last).Preelab := True;
2821                elsif C = 'U' then
2822                   Units.Table (Units.Last).Pure := True;
2823                elsif C = 'K' then
2824                   Units.Table (Units.Last).Unit_Kind := 'p';
2825                else
2826                   Fatal_Error_Ignore;
2827                end if;
2828
2829                Check_At_End_Of_Field;
2830
2831             --  OL/OO/OS/OT parameters
2832
2833             elsif C = 'O' then
2834                C := Getc;
2835
2836                if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
2837                   Units.Table (Units.Last).Optimize_Alignment := C;
2838                else
2839                   Fatal_Error_Ignore;
2840                end if;
2841
2842                Check_At_End_Of_Field;
2843
2844             --  RC/RT parameters
2845
2846             elsif C = 'R' then
2847                C := Getc;
2848
2849                if C = 'C' then
2850                   Units.Table (Units.Last).RCI := True;
2851                elsif C = 'T' then
2852                   Units.Table (Units.Last).Remote_Types := True;
2853                elsif C = 'A' then
2854                   Units.Table (Units.Last).Has_RACW := True;
2855                else
2856                   Fatal_Error_Ignore;
2857                end if;
2858
2859                Check_At_End_Of_Field;
2860
2861             --  SE/SP/SU parameters
2862
2863             elsif C = 'S' then
2864                C := Getc;
2865
2866                if C = 'E' then
2867                   Units.Table (Units.Last).Serious_Errors := True;
2868                elsif C = 'P' then
2869                   Units.Table (Units.Last).Shared_Passive := True;
2870                elsif C = 'U' then
2871                   Units.Table (Units.Last).Unit_Kind := 's';
2872                else
2873                   Fatal_Error_Ignore;
2874                end if;
2875
2876                Check_At_End_Of_Field;
2877
2878             else
2879                C := Getc;
2880                Fatal_Error_Ignore;
2881             end if;
2882          end loop;
2883
2884          Skip_Eol;
2885
2886          C := Getc;
2887
2888          --  Scan out With lines for this unit
2889
2890          With_Loop : loop
2891             Check_Unknown_Line;
2892             exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
2893
2894             if Ignore ('W') then
2895                Skip_Line;
2896
2897             else
2898                Checkc (' ');
2899                Skip_Space;
2900                Withs.Increment_Last;
2901                Withs.Table (Withs.Last).Uname              := Get_Unit_Name;
2902                Withs.Table (Withs.Last).Elaborate          := False;
2903                Withs.Table (Withs.Last).Elaborate_All      := False;
2904                Withs.Table (Withs.Last).Elab_Desirable     := False;
2905                Withs.Table (Withs.Last).Elab_All_Desirable := False;
2906                Withs.Table (Withs.Last).SAL_Interface      := False;
2907                Withs.Table (Withs.Last).Limited_With       := (C = 'Y');
2908                Withs.Table (Withs.Last).Implicit_With      := (C = 'Z');
2909
2910                --  Generic case with no object file available
2911
2912                if At_Eol then
2913                   Withs.Table (Withs.Last).Sfile := No_File;
2914                   Withs.Table (Withs.Last).Afile := No_File;
2915
2916                --  Normal case
2917
2918                else
2919                   Withs.Table (Withs.Last).Sfile := Get_File_Name
2920                                                       (Lower => True);
2921                   Withs.Table (Withs.Last).Afile := Get_File_Name
2922                                                       (Lower => True);
2923
2924                   --  Scan out possible E, EA, ED, and AD parameters
2925
2926                   while not At_Eol loop
2927                      Skip_Space;
2928
2929                      if Nextc = 'A' then
2930                         P := P + 1;
2931                         Checkc ('D');
2932                         Check_At_End_Of_Field;
2933
2934                         --  Store AD indication unless ignore required
2935
2936                         Withs.Table (Withs.Last).Elab_All_Desirable := True;
2937
2938                      elsif Nextc = 'E' then
2939                         P := P + 1;
2940
2941                         if At_End_Of_Field then
2942                            Withs.Table (Withs.Last).Elaborate := True;
2943
2944                         elsif Nextc = 'A' then
2945                            P := P + 1;
2946                            Check_At_End_Of_Field;
2947                            Withs.Table (Withs.Last).Elaborate_All := True;
2948
2949                         else
2950                            Checkc ('D');
2951                            Check_At_End_Of_Field;
2952
2953                            --  Store ED indication
2954
2955                            Withs.Table (Withs.Last).Elab_Desirable := True;
2956                         end if;
2957
2958                      else
2959                         Fatal_Error;
2960                      end if;
2961                   end loop;
2962                end if;
2963
2964                Skip_Eol;
2965             end if;
2966
2967             C := Getc;
2968          end loop With_Loop;
2969
2970          Units.Table (Units.Last).Last_With := Withs.Last;
2971          Units.Table (Units.Last).Last_Arg  := Args.Last;
2972
2973          --  Scan out task stack information for the unit if present
2974
2975          Check_Unknown_Line;
2976
2977          if C = 'T' then
2978             if Ignore ('T') then
2979                Skip_Line;
2980
2981             else
2982                Checkc (' ');
2983                Skip_Space;
2984
2985                Units.Table (Units.Last).Primary_Stack_Count := Get_Nat;
2986                Skip_Space;
2987                Units.Table (Units.Last).Sec_Stack_Count := Get_Nat;
2988                Skip_Space;
2989                Skip_Eol;
2990             end if;
2991
2992             C := Getc;
2993          end if;
2994
2995          --  If there are linker options lines present, scan them
2996
2997          Name_Len := 0;
2998
2999          Linker_Options_Loop : loop
3000             Check_Unknown_Line;
3001             exit Linker_Options_Loop when C /= 'L';
3002
3003             if Ignore ('L') then
3004                Skip_Line;
3005
3006             else
3007                Checkc (' ');
3008                Skip_Space;
3009                Checkc ('"');
3010
3011                loop
3012                   C := Getc;
3013
3014                   if C < Character'Val (16#20#)
3015                     or else C > Character'Val (16#7E#)
3016                   then
3017                      Fatal_Error_Ignore;
3018
3019                   elsif C = '{' then
3020                      C := Character'Val (0);
3021
3022                      declare
3023                         V : Natural;
3024
3025                      begin
3026                         V := 0;
3027                         for J in 1 .. 2 loop
3028                            C := Getc;
3029
3030                            if C in '0' .. '9' then
3031                               V := V * 16 +
3032                                      Character'Pos (C) -
3033                                        Character'Pos ('0');
3034
3035                            elsif C in 'A' .. 'F' then
3036                               V := V * 16 +
3037                                      Character'Pos (C) -
3038                                        Character'Pos ('A') +
3039                                          10;
3040
3041                            else
3042                               Fatal_Error_Ignore;
3043                            end if;
3044                         end loop;
3045
3046                         Checkc ('}');
3047                         Add_Char_To_Name_Buffer (Character'Val (V));
3048                      end;
3049
3050                   else
3051                      if C = '"' then
3052                         exit when Nextc /= '"';
3053                         C := Getc;
3054                      end if;
3055
3056                      Add_Char_To_Name_Buffer (C);
3057                   end if;
3058                end loop;
3059
3060                Add_Char_To_Name_Buffer (NUL);
3061                Skip_Eol;
3062             end if;
3063
3064             C := Getc;
3065          end loop Linker_Options_Loop;
3066
3067          --  Store the linker options entry if one was found
3068
3069          if Name_Len /= 0 then
3070             Linker_Options.Increment_Last;
3071
3072             Linker_Options.Table (Linker_Options.Last).Name :=
3073               Name_Enter;
3074
3075             Linker_Options.Table (Linker_Options.Last).Unit :=
3076               Units.Last;
3077
3078             Linker_Options.Table (Linker_Options.Last).Internal_File :=
3079               Is_Internal_File_Name (F);
3080          end if;
3081
3082          --  If there are notes present, scan them
3083
3084          Notes_Loop : loop
3085             Check_Unknown_Line;
3086             exit Notes_Loop when C /= 'N';
3087
3088             if Ignore ('N') then
3089                Skip_Line;
3090
3091             else
3092                Checkc (' ');
3093
3094                Notes.Increment_Last;
3095                Notes.Table (Notes.Last).Pragma_Type := Getc;
3096                Notes.Table (Notes.Last).Pragma_Line := Get_Nat;
3097                Checkc (':');
3098                Notes.Table (Notes.Last).Pragma_Col  := Get_Nat;
3099
3100                if not At_Eol and then Nextc = ':' then
3101                   Checkc (':');
3102                   Notes.Table (Notes.Last).Pragma_Source_File :=
3103                     Get_File_Name (Lower => True);
3104                else
3105                   Notes.Table (Notes.Last).Pragma_Source_File :=
3106                     Units.Table (Units.Last).Sfile;
3107                end if;
3108
3109                if At_Eol then
3110                   Notes.Table (Notes.Last).Pragma_Args := No_Name;
3111
3112                else
3113                   --  Note: can't use Get_Name here as the remainder of the
3114                   --  line is unstructured text whose syntax depends on the
3115                   --  particular pragma used.
3116
3117                   Checkc (' ');
3118
3119                   Name_Len := 0;
3120                   while not At_Eol loop
3121                      Add_Char_To_Name_Buffer (Getc);
3122                   end loop;
3123                end if;
3124
3125                Skip_Eol;
3126             end if;
3127
3128             C := Getc;
3129          end loop Notes_Loop;
3130       end loop U_Loop;
3131
3132       --  End loop through units for one ALI file
3133
3134       ALIs.Table (Id).Last_Unit := Units.Last;
3135       ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
3136
3137       --  Set types of the units (there can be at most 2 of them)
3138
3139       if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
3140          Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
3141          Units.Table (ALIs.Table (Id).Last_Unit).Utype  := Is_Spec;
3142
3143       else
3144          --  Deal with body only and spec only cases, note that the reason we
3145          --  do our own checking of the name (rather than using Is_Body_Name)
3146          --  is that Uname drags in far too much compiler junk.
3147
3148          Get_Name_String (Units.Table (Units.Last).Uname);
3149
3150          if Name_Buffer (Name_Len) = 'b' then
3151             Units.Table (Units.Last).Utype := Is_Body_Only;
3152          else
3153             Units.Table (Units.Last).Utype := Is_Spec_Only;
3154          end if;
3155       end if;
3156
3157       --  Scan out external version references and put in hash table
3158
3159       E_Loop : loop
3160          Check_Unknown_Line;
3161          exit E_Loop when C /= 'E';
3162
3163          if Ignore ('E') then
3164             Skip_Line;
3165
3166          else
3167             Checkc (' ');
3168             Skip_Space;
3169
3170             Name_Len := 0;
3171             Name_Len := 0;
3172             loop
3173                C := Getc;
3174
3175                if C < ' ' then
3176                   Fatal_Error;
3177                end if;
3178
3179                exit when At_End_Of_Field;
3180                Add_Char_To_Name_Buffer (C);
3181             end loop;
3182
3183             Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
3184             Skip_Eol;
3185          end if;
3186
3187          C := Getc;
3188       end loop E_Loop;
3189
3190       --  Scan out source dependency lines for this ALI file
3191
3192       ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
3193
3194       D_Loop : loop
3195          Check_Unknown_Line;
3196          exit D_Loop when C /= 'D';
3197
3198          if Ignore ('D') then
3199             Skip_Line;
3200
3201          else
3202             Checkc (' ');
3203             Skip_Space;
3204             Sdep.Increment_Last;
3205
3206             --  The file/path name may be quoted
3207
3208             Sdep.Table (Sdep.Last).Sfile :=
3209               Get_File_Name (Lower => True, May_Be_Quoted => True);
3210
3211             Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
3212             Sdep.Table (Sdep.Last).Dummy_Entry :=
3213               (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
3214
3215             --  Acquire checksum value
3216
3217             Skip_Space;
3218
3219             declare
3220                Ctr : Natural;
3221                Chk : Word;
3222
3223             begin
3224                Ctr := 0;
3225                Chk := 0;
3226
3227                loop
3228                   exit when At_Eol or else Ctr = 8;
3229
3230                   if Nextc in '0' .. '9' then
3231                      Chk := Chk * 16 +
3232                               Character'Pos (Nextc) - Character'Pos ('0');
3233
3234                   elsif Nextc in 'a' .. 'f' then
3235                      Chk := Chk * 16 +
3236                               Character'Pos (Nextc) - Character'Pos ('a') + 10;
3237
3238                   else
3239                      exit;
3240                   end if;
3241
3242                   Ctr := Ctr + 1;
3243                   P := P + 1;
3244                end loop;
3245
3246                if Ctr = 8 and then At_End_Of_Field then
3247                   Sdep.Table (Sdep.Last).Checksum := Chk;
3248                else
3249                   Fatal_Error;
3250                end if;
3251             end;
3252
3253             --  Acquire (sub)unit and reference file name entries
3254
3255             Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
3256             Sdep.Table (Sdep.Last).Unit_Name    := No_Name;
3257             Sdep.Table (Sdep.Last).Rfile        :=
3258               Sdep.Table (Sdep.Last).Sfile;
3259             Sdep.Table (Sdep.Last).Start_Line   := 1;
3260
3261             if not At_Eol then
3262                Skip_Space;
3263
3264                --  Here for (sub)unit name
3265
3266                if Nextc not in '0' .. '9' then
3267                   Name_Len := 0;
3268                   while not At_End_Of_Field loop
3269                      Add_Char_To_Name_Buffer (Getc);
3270                   end loop;
3271
3272                   --  Set the (sub)unit name. Note that we use Name_Find rather
3273                   --  than Name_Enter here as the subunit name may already
3274                   --  have been put in the name table by the Project Manager.
3275
3276                   if Name_Len <= 2
3277                     or else Name_Buffer (Name_Len - 1) /= '%'
3278                   then
3279                      Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
3280                   else
3281                      Name_Len := Name_Len - 2;
3282                      Sdep.Table (Sdep.Last).Unit_Name := Name_Find;
3283                   end if;
3284
3285                   Skip_Space;
3286                end if;
3287
3288                --  Here for reference file name entry
3289
3290                if Nextc in '0' .. '9' then
3291                   Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
3292                   Checkc (':');
3293
3294                   Name_Len := 0;
3295
3296                   while not At_End_Of_Field loop
3297                      Add_Char_To_Name_Buffer (Getc);
3298                   end loop;
3299
3300                   Sdep.Table (Sdep.Last).Rfile := Name_Enter;
3301                end if;
3302             end if;
3303
3304             Skip_Eol;
3305          end if;
3306
3307          C := Getc;
3308       end loop D_Loop;
3309
3310       ALIs.Table (Id).Last_Sdep := Sdep.Last;
3311
3312       --  Loop through invocation-graph lines
3313
3314       G_Loop : loop
3315          Check_Unknown_Line;
3316          exit G_Loop when C /= 'G';
3317
3318          Scan_Invocation_Graph_Line;
3319
3320          C := Getc;
3321       end loop G_Loop;
3322
3323       --  We must at this stage be at an Xref line or the end of file
3324
3325       if C = EOF then
3326          return Id;
3327       end if;
3328
3329       Check_Unknown_Line;
3330
3331       if C /= 'X' then
3332          Fatal_Error;
3333       end if;
3334
3335       --  This ALI parser does not care about Xref lines.
3336
3337       return Id;
3338
3339    exception
3340       when Bad_ALI_Format =>
3341          return No_ALI_Id;
3342    end Scan_ALI;
3343
3344    --------------
3345    -- IS_Scope --
3346    --------------
3347
3348    function IS_Scope (IS_Id : Invocation_Signature_Id) return Name_Id is
3349    begin
3350       pragma Assert (Present (IS_Id));
3351       return Invocation_Signatures.Table (IS_Id).Scope;
3352    end IS_Scope;
3353
3354    ---------
3355    -- SEq --
3356    ---------
3357
3358    function SEq (F1, F2 : String_Ptr) return Boolean is
3359    begin
3360       return F1.all = F2.all;
3361    end SEq;
3362
3363    -----------------------------------
3364    -- Set_Invocation_Graph_Encoding --
3365    -----------------------------------
3366
3367    procedure Set_Invocation_Graph_Encoding
3368      (Kind         : Invocation_Graph_Encoding_Kind;
3369       Update_Units : Boolean := True)
3370    is
3371    begin
3372       Compile_Time_Invocation_Graph_Encoding := Kind;
3373
3374       --  Update the invocation-graph encoding of the current unit only when
3375       --  requested by the caller.
3376
3377       if Update_Units then
3378          declare
3379             Curr_Unit : Unit_Record renames Units.Table (Units.Last);
3380             Curr_ALI  : ALIs_Record renames ALIs.Table  (Curr_Unit.My_ALI);
3381
3382          begin
3383             Curr_ALI.Invocation_Graph_Encoding := Kind;
3384          end;
3385       end if;
3386    end Set_Invocation_Graph_Encoding;
3387
3388    -----------
3389    -- SHash --
3390    -----------
3391
3392    function SHash (S : String_Ptr) return Vindex is
3393       H : Word;
3394
3395    begin
3396       H := 0;
3397       for J in S.all'Range loop
3398          H := H * 2 + Character'Pos (S (J));
3399       end loop;
3400
3401       return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
3402    end SHash;
3403
3404    ---------------
3405    -- Signature --
3406    ---------------
3407
3408    function Signature
3409      (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id
3410    is
3411    begin
3412       pragma Assert (Present (IC_Id));
3413       return Invocation_Constructs.Table (IC_Id).Signature;
3414    end Signature;
3415
3416    --------------------
3417    -- Spec_Placement --
3418    --------------------
3419
3420    function Spec_Placement
3421      (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind
3422    is
3423    begin
3424       pragma Assert (Present (IC_Id));
3425       return Invocation_Constructs.Table (IC_Id).Spec_Placement;
3426    end Spec_Placement;
3427
3428    ------------
3429    -- Target --
3430    ------------
3431
3432    function Target
3433      (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id
3434    is
3435    begin
3436       pragma Assert (Present (IR_Id));
3437       return Invocation_Relations.Table (IR_Id).Target;
3438    end Target;
3439
3440 end ALI;