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