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-2004 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Butil;    use Butil;
  28 with Debug;    use Debug;
  29 with Fname;    use Fname;
  30 with Namet;    use Namet;
  31 with Opt;      use Opt;
  32 with Osint;    use Osint;
  33 with Output;   use Output;
  34
  35 package body ALI is
  36
  37    use ASCII;
  38    --  Make control characters visible
  39
  40    --------------------
  41    -- Initialize_ALI --
  42    --------------------
  43
  44    procedure Initialize_ALI is
  45    begin
  46       --  When (re)initializing ALI data structures the ALI user expects to
  47       --  get a fresh set of data structures. Thus we first need to erase the
  48       --  marks put in the name table by the previous set of ALI routine calls.
  49       --  These two loops are empty and harmless the first time in.
  50
  51       for J in ALIs.First .. ALIs.Last loop
  52          Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
  53       end loop;
  54
  55       for J in Units.First .. Units.Last loop
  56          Set_Name_Table_Info (Units.Table (J).Uname, 0);
  57       end loop;
  58
  59       --  Free argument table strings
  60
  61       for J in Args.First .. Args.Last loop
  62          Free (Args.Table (J));
  63       end loop;
  64
  65       --  Initialize all tables
  66
  67       ALIs.Init;
  68       Units.Init;
  69       Withs.Init;
  70       Sdep.Init;
  71       Linker_Options.Init;
  72       Xref_Section.Init;
  73       Xref_Entity.Init;
  74       Xref.Init;
  75       Version_Ref.Reset;
  76
  77       --  Add dummy zero'th item in Linker_Options for the sort function
  78
  79       Linker_Options.Increment_Last;
  80
  81       --  Initialize global variables recording cumulative options in all
  82       --  ALI files that are read for a given processing run in gnatbind.
  83
  84       Dynamic_Elaboration_Checks_Specified := False;
  85       Float_Format_Specified               := ' ';
  86       Locking_Policy_Specified             := ' ';
  87       No_Normalize_Scalars_Specified       := False;
  88       No_Object_Specified                  := False;
  89       Normalize_Scalars_Specified          := False;
  90       Queuing_Policy_Specified             := ' ';
  91       Static_Elaboration_Model_Used        := False;
  92       Task_Dispatching_Policy_Specified    := ' ';
  93       Unreserve_All_Interrupts_Specified   := False;
  94       Zero_Cost_Exceptions_Specified       := False;
  95    end Initialize_ALI;
  96
  97    --------------
  98    -- Scan_ALI --
  99    --------------
 100
 101    function Scan_ALI
 102      (F            : File_Name_Type;
 103       T            : Text_Buffer_Ptr;
 104       Ignore_ED    : Boolean;
 105       Err          : Boolean;
 106       Read_Xref    : Boolean := False;
 107       Read_Lines   : String := "";
 108       Ignore_Lines : String := "X")
 109       return         ALI_Id
 110    is
 111       P         : Text_Ptr := T'First;
 112       Line      : Logical_Line_Number := 1;
 113       Id        : ALI_Id;
 114       C         : Character;
 115       NS_Found  : Boolean;
 116       First_Arg : Arg_Id;
 117
 118       Ignore : array (Character range 'A' .. 'Z') of Boolean;
 119       --  Ignore (X) is set to True if lines starting with X are to
 120       --  be ignored by Scan_ALI and skipped, and False if the lines
 121       --  are to be read and processed.
 122
 123       Restrictions_Initial : Rident.Restrictions_Info;
 124       pragma Warnings (Off, Restrictions_Initial);
 125       --  This variable, which should really be a constant (but that's not
 126       --  allowed by the language) is used only for initialization, and the
 127       --  reason we are declaring it is to get the default initialization
 128       --  set for the object.
 129
 130       Bad_ALI_Format : exception;
 131       --  Exception raised by Fatal_Error if Err is True
 132
 133       function At_Eol return Boolean;
 134       --  Test if at end of line
 135
 136       function At_End_Of_Field return Boolean;
 137       --  Test if at end of line, or if at blank or horizontal tab
 138
 139       procedure Check_At_End_Of_Field;
 140       --  Check if we are at end of field, fatal error if not
 141
 142       procedure Checkc (C : Character);
 143       --  Check next character is C. If so bump past it, if not fatal error
 144
 145       procedure Fatal_Error;
 146       --  Generate fatal error message for badly formatted ALI file if
 147       --  Err is false, or raise Bad_ALI_Format if Err is True.
 148
 149       function Getc return Character;
 150       --  Get next character, bumping P past the character obtained
 151
 152       function Get_Name
 153         (Lower         : Boolean := False;
 154          Ignore_Spaces : Boolean := False) return Name_Id;
 155       --  Skip blanks, then scan out a name (name is left in Name_Buffer with
 156       --  length in Name_Len, as well as being returned in Name_Id form).
 157       --  If Lower is set to True then the Name_Buffer will be converted to
 158       --  all lower case, for systems where file names are not case sensitive.
 159       --  This ensures that gnatbind works correctly regardless of the case
 160       --  of the file name on all systems. The name is terminated by a either
 161       --  white space (when Ignore_Spaces is False) or a typeref bracket or
 162       --  an equal sign except for the special case of an operator name
 163       --  starting with a double quite which is terminated by another double
 164       --  quote.
 165
 166       function Get_Nat return Nat;
 167       --  Skip blanks, then scan out an unsigned integer value in Nat range.
 168
 169       function Get_Stamp return Time_Stamp_Type;
 170       --  Skip blanks, then scan out a time stamp
 171
 172       function Nextc return Character;
 173       --  Return current character without modifying pointer P
 174
 175       procedure Skip_Eol;
 176       --  Skip past spaces, then skip past end of line (fatal error if not
 177       --  at end of line). Also skips past any following blank lines.
 178
 179       procedure Skip_Line;
 180       --  Skip rest of current line and any following blank lines.
 181
 182       procedure Skip_Space;
 183       --  Skip past white space (blanks or horizontal tab)
 184
 185       procedure Skipc;
 186       --  Skip past next character, does not affect value in C. This call
 187       --  is like calling Getc and ignoring the returned result.
 188
 189       ---------------------
 190       -- At_End_Of_Field --
 191       ---------------------
 192
 193       function At_End_Of_Field return Boolean is
 194       begin
 195          return Nextc <= ' ';
 196       end At_End_Of_Field;
 197
 198       ------------
 199       -- At_Eol --
 200       ------------
 201
 202       function At_Eol return Boolean is
 203       begin
 204          return Nextc = EOF or else Nextc = CR or else Nextc = LF;
 205       end At_Eol;
 206
 207       ---------------------------
 208       -- Check_At_End_Of_Field --
 209       ---------------------------
 210
 211       procedure Check_At_End_Of_Field is
 212       begin
 213          if not At_End_Of_Field then
 214             Fatal_Error;
 215          end if;
 216       end Check_At_End_Of_Field;
 217
 218       ------------
 219       -- Checkc --
 220       ------------
 221
 222       procedure Checkc (C : Character) is
 223       begin
 224          if Nextc = C then
 225             P := P + 1;
 226          else
 227             Fatal_Error;
 228          end if;
 229       end Checkc;
 230
 231       -----------------
 232       -- Fatal_Error --
 233       -----------------
 234
 235       procedure Fatal_Error is
 236          Ptr1 : Text_Ptr;
 237          Ptr2 : Text_Ptr;
 238          Col  : Int;
 239
 240          procedure Wchar (C : Character);
 241          --  Write a single character, replacing horizontal tab by spaces
 242
 243          procedure Wchar (C : Character) is
 244          begin
 245             if C = HT then
 246                loop
 247                   Wchar (' ');
 248                   exit when Col mod 8 = 0;
 249                end loop;
 250
 251             else
 252                Write_Char (C);
 253                Col := Col + 1;
 254             end if;
 255          end Wchar;
 256
 257       --  Start of processing for Fatal_Error
 258
 259       begin
 260          if Err then
 261             raise Bad_ALI_Format;
 262          end if;
 263
 264          Set_Standard_Error;
 265          Write_Str ("fatal error: file ");
 266          Write_Name (F);
 267          Write_Str (" is incorrectly formatted");
 268          Write_Eol;
 269          Write_Str
 270            ("make sure you are using consistent versions of gcc/gnatbind");
 271          Write_Eol;
 272
 273          --  Find start of line
 274
 275          Ptr1 := P;
 276
 277          while Ptr1 > T'First
 278            and then T (Ptr1 - 1) /= CR
 279            and then T (Ptr1 - 1) /= LF
 280          loop
 281             Ptr1 := Ptr1 - 1;
 282          end loop;
 283
 284          Write_Int (Int (Line));
 285          Write_Str (". ");
 286
 287          if Line < 100 then
 288             Write_Char (' ');
 289          end if;
 290
 291          if Line < 10 then
 292             Write_Char (' ');
 293          end if;
 294
 295          Col := 0;
 296          Ptr2 := Ptr1;
 297
 298          while Ptr2 < T'Last
 299            and then T (Ptr2) /= CR
 300            and then T (Ptr2) /= LF
 301          loop
 302             Wchar (T (Ptr2));
 303             Ptr2 := Ptr2 + 1;
 304          end loop;
 305
 306          Write_Eol;
 307
 308          Write_Str ("     ");
 309          Col := 0;
 310
 311          while Ptr1 < P loop
 312             if T (Ptr1) = HT then
 313                Wchar (HT);
 314             else
 315                Wchar (' ');
 316             end if;
 317
 318             Ptr1 := Ptr1 + 1;
 319          end loop;
 320
 321          Wchar ('|');
 322          Write_Eol;
 323
 324          Exit_Program (E_Fatal);
 325       end Fatal_Error;
 326
 327       --------------
 328       -- Get_Name --
 329       --------------
 330
 331       function Get_Name (Lower : Boolean := False;
 332                          Ignore_Spaces : Boolean := False) return Name_Id is
 333       begin
 334          Name_Len := 0;
 335          Skip_Space;
 336
 337          if At_Eol then
 338             Fatal_Error;
 339          end if;
 340
 341          loop
 342             Name_Len := Name_Len + 1;
 343             Name_Buffer (Name_Len) := Getc;
 344
 345             exit when At_End_Of_Field and not Ignore_Spaces;
 346
 347             if Name_Buffer (1) = '"' then
 348                exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
 349
 350             else
 351                exit when (At_End_Of_Field and not Ignore_Spaces)
 352                  or else Nextc = '(' or else Nextc = ')'
 353                  or else Nextc = '{' or else Nextc = '}'
 354                  or else Nextc = '<' or else Nextc = '>'
 355                  or else Nextc = '=';
 356             end if;
 357          end loop;
 358
 359          --  Convert file name to all lower case if file names are not case
 360          --  sensitive. This ensures that we handle names in the canonical
 361          --  lower case format, regardless of the actual case.
 362
 363          if Lower and not File_Names_Case_Sensitive then
 364             Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
 365          end if;
 366
 367          return Name_Find;
 368       end Get_Name;
 369
 370       -------------
 371       -- Get_Nat --
 372       -------------
 373
 374       function Get_Nat return Nat is
 375          V : Nat;
 376
 377       begin
 378          Skip_Space;
 379
 380          V := 0;
 381          loop
 382             V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
 383             exit when At_End_Of_Field;
 384             exit when Nextc < '0' or Nextc > '9';
 385          end loop;
 386
 387          return V;
 388       end Get_Nat;
 389
 390       ---------------
 391       -- Get_Stamp --
 392       ---------------
 393
 394       function Get_Stamp return Time_Stamp_Type is
 395          T     : Time_Stamp_Type;
 396          Start : Integer;
 397
 398       begin
 399          Skip_Space;
 400
 401          if At_Eol then
 402             Fatal_Error;
 403          end if;
 404
 405          --  Following reads old style time stamp missing first two digits
 406
 407          if Nextc in '7' .. '9' then
 408             T (1) := '1';
 409             T (2) := '9';
 410             Start := 3;
 411
 412          --  Normal case of full year in time stamp
 413
 414          else
 415             Start := 1;
 416          end if;
 417
 418          for J in Start .. T'Last loop
 419             T (J) := Getc;
 420          end loop;
 421
 422          return T;
 423       end Get_Stamp;
 424
 425       ----------
 426       -- Getc --
 427       ----------
 428
 429       function Getc return Character is
 430       begin
 431          if P = T'Last then
 432             return EOF;
 433          else
 434             P := P + 1;
 435             return T (P - 1);
 436          end if;
 437       end Getc;
 438
 439       -----------
 440       -- Nextc --
 441       -----------
 442
 443       function Nextc return Character is
 444       begin
 445          return T (P);
 446       end Nextc;
 447
 448       --------------
 449       -- Skip_Eol --
 450       --------------
 451
 452       procedure Skip_Eol is
 453       begin
 454          Skip_Space;
 455
 456          if not At_Eol then Fatal_Error; end if;
 457
 458          --  Loop to skip past blank lines (first time through skips this EOL)
 459
 460          while Nextc < ' ' and then Nextc /= EOF loop
 461             if Nextc = LF then
 462                Line := Line + 1;
 463             end if;
 464
 465             P := P + 1;
 466          end loop;
 467       end Skip_Eol;
 468
 469       ---------------
 470       -- Skip_Line --
 471       ---------------
 472
 473       procedure Skip_Line is
 474       begin
 475          while not At_Eol loop
 476             P := P + 1;
 477          end loop;
 478
 479          Skip_Eol;
 480       end Skip_Line;
 481
 482       ----------------
 483       -- Skip_Space --
 484       ----------------
 485
 486       procedure Skip_Space is
 487       begin
 488          while Nextc = ' ' or else Nextc = HT loop
 489             P := P + 1;
 490          end loop;
 491       end Skip_Space;
 492
 493       -----------
 494       -- Skipc --
 495       -----------
 496
 497       procedure Skipc is
 498       begin
 499          if P /= T'Last then
 500             P := P + 1;
 501          end if;
 502       end Skipc;
 503
 504    --  Start of processing for Scan_ALI
 505
 506    begin
 507       --  Acquire lines to be ignored
 508
 509       if Read_Xref then
 510          Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True);
 511
 512       --  Read_Lines parameter given
 513
 514       elsif Read_Lines /= "" then
 515          Ignore := ('U' => False, others => True);
 516
 517          for J in Read_Lines'Range loop
 518             Ignore (Read_Lines (J)) := False;
 519          end loop;
 520
 521       --  Process Ignore_Lines parameter
 522
 523       else
 524          Ignore := (others => False);
 525
 526          for J in Ignore_Lines'Range loop
 527             pragma Assert (Ignore_Lines (J) /= 'U');
 528             Ignore (Ignore_Lines (J)) := True;
 529          end loop;
 530       end if;
 531
 532       --  Setup ALI Table entry with appropriate defaults
 533
 534       ALIs.Increment_Last;
 535       Id := ALIs.Last;
 536       Set_Name_Table_Info (F, Int (Id));
 537
 538       ALIs.Table (Id) := (
 539         Afile                      => F,
 540         Compile_Errors             => False,
 541         First_Interrupt_State      => Interrupt_States.Last + 1,
 542         First_Sdep                 => No_Sdep_Id,
 543         First_Unit                 => No_Unit_Id,
 544         Float_Format               => 'I',
 545         Last_Interrupt_State       => Interrupt_States.Last,
 546         Last_Sdep                  => No_Sdep_Id,
 547         Last_Unit                  => No_Unit_Id,
 548         Locking_Policy             => ' ',
 549         Main_Priority              => -1,
 550         Main_Program               => None,
 551         No_Object                  => False,
 552         Normalize_Scalars          => False,
 553         Ofile_Full_Name            => Full_Object_File_Name,
 554         Queuing_Policy             => ' ',
 555         Restrictions               => Restrictions_Initial,
 556         Sfile                      => No_Name,
 557         Task_Dispatching_Policy    => ' ',
 558         Time_Slice_Value           => -1,
 559         WC_Encoding                => '8',
 560         Unit_Exception_Table       => False,
 561         Ver                        => (others => ' '),
 562         Ver_Len                    => 0,
 563         Interface                  => False,
 564         Zero_Cost_Exceptions       => False);
 565
 566       --  Now we acquire the input lines from the ALI file. Note that the
 567       --  convention in the following code is that as we enter each section,
 568       --  C is set to contain the first character of the following line.
 569
 570       C := Getc;
 571
 572       --  Acquire library version
 573
 574       if C /= 'V' then
 575          Fatal_Error;
 576
 577       elsif Ignore ('V') then
 578          Skip_Line;
 579
 580       else
 581          Checkc (' ');
 582          Skip_Space;
 583          Checkc ('"');
 584
 585          for J in 1 .. Ver_Len_Max loop
 586             C := Getc;
 587             exit when C = '"';
 588             ALIs.Table (Id).Ver (J) := C;
 589             ALIs.Table (Id).Ver_Len := J;
 590          end loop;
 591
 592          Skip_Eol;
 593       end if;
 594
 595       C := Getc;
 596
 597       --  Acquire main program line if present
 598
 599       if C = 'M' then
 600          if Ignore ('M') then
 601             Skip_Line;
 602
 603          else
 604             Checkc (' ');
 605             Skip_Space;
 606
 607             C := Getc;
 608
 609             if C = 'F' then
 610                ALIs.Table (Id).Main_Program := Func;
 611             elsif C = 'P' then
 612                ALIs.Table (Id).Main_Program := Proc;
 613             else
 614                P := P - 1;
 615                Fatal_Error;
 616             end if;
 617
 618             Skip_Space;
 619
 620             if not At_Eol then
 621                if Nextc < 'A' then
 622                   ALIs.Table (Id).Main_Priority := Get_Nat;
 623                end if;
 624
 625                Skip_Space;
 626
 627                if Nextc = 'T' then
 628                   P := P + 1;
 629                   Checkc ('=');
 630                   ALIs.Table (Id).Time_Slice_Value := Get_Nat;
 631                end if;
 632
 633                Skip_Space;
 634
 635                Checkc ('W');
 636                Checkc ('=');
 637                ALIs.Table (Id).WC_Encoding := Getc;
 638             end if;
 639
 640             Skip_Eol;
 641          end if;
 642
 643          C := Getc;
 644       end if;
 645
 646       --  Acquire argument lines
 647
 648       First_Arg := Args.Last + 1;
 649
 650       Arg_Loop : while C = 'A' loop
 651          if Ignore ('A') then
 652             Skip_Line;
 653
 654          else
 655             Checkc (' ');
 656             Name_Len := 0;
 657
 658             while not At_Eol loop
 659                Name_Len := Name_Len + 1;
 660                Name_Buffer (Name_Len) := Getc;
 661             end loop;
 662
 663             Args.Increment_Last;
 664             Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
 665
 666             Skip_Eol;
 667          end if;
 668
 669          C := Getc;
 670       end loop Arg_Loop;
 671
 672       --  Acquire P line
 673
 674       if C /= 'P' then
 675          Fatal_Error;
 676
 677       elsif Ignore ('P') then
 678          Skip_Line;
 679
 680       else
 681          NS_Found := False;
 682
 683          while not At_Eol loop
 684             Checkc (' ');
 685             Skip_Space;
 686             C := Getc;
 687
 688             --  Processing for CE
 689
 690             if C = 'C' then
 691                Checkc ('E');
 692                ALIs.Table (Id).Compile_Errors := True;
 693
 694             --  Processing for FD/FG/FI
 695
 696             elsif C = 'F' then
 697                Float_Format_Specified := Getc;
 698                ALIs.Table (Id).Float_Format := Float_Format_Specified;
 699
 700             --  Processing for Lx
 701
 702             elsif C = 'L' then
 703                Locking_Policy_Specified := Getc;
 704                ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
 705
 706             --  Processing for flags starting with N
 707
 708             elsif C = 'N' then
 709                C := Getc;
 710
 711                --  Processing for NO
 712
 713                if C = 'O' then
 714                   ALIs.Table (Id).No_Object := True;
 715                   No_Object_Specified := True;
 716
 717                --  Processing for NR
 718
 719                elsif C = 'R' then
 720                   No_Run_Time_Mode           := True;
 721                   Configurable_Run_Time_Mode := True;
 722
 723                --  Processing for NS
 724
 725                elsif C = 'S' then
 726                   ALIs.Table (Id).Normalize_Scalars := True;
 727                   Normalize_Scalars_Specified := True;
 728                   NS_Found := True;
 729
 730                --  Invalid switch starting with N
 731
 732                else
 733                   Fatal_Error;
 734                end if;
 735
 736             --  Processing for Qx
 737
 738             elsif C = 'Q' then
 739                Queuing_Policy_Specified := Getc;
 740                ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
 741
 742             --  Processing for flags starting with S
 743
 744             elsif C = 'S' then
 745                C := Getc;
 746
 747                --  Processing for SL
 748
 749                if C = 'L' then
 750                   ALIs.Table (Id).Interface := True;
 751
 752                --  Processing for SS
 753
 754                elsif C = 'S' then
 755                   Opt.Sec_Stack_Used := True;
 756
 757                --  Invalid switch starting with S
 758
 759                else
 760                   Fatal_Error;
 761                end if;
 762
 763             --  Processing for Tx
 764
 765             elsif C = 'T' then
 766                Task_Dispatching_Policy_Specified := Getc;
 767                ALIs.Table (Id).Task_Dispatching_Policy :=
 768                  Task_Dispatching_Policy_Specified;
 769
 770             --  Processing for switch starting with U
 771
 772             elsif C = 'U' then
 773                C := Getc;
 774
 775                --  Processing for UA
 776
 777                if C  = 'A' then
 778                   Unreserve_All_Interrupts_Specified := True;
 779
 780                --  Processing for UX
 781
 782                elsif C = 'X' then
 783                   ALIs.Table (Id).Unit_Exception_Table := True;
 784
 785                --  Invalid switches starting with U
 786
 787                else
 788                   Fatal_Error;
 789                end if;
 790
 791             --  Processing for ZX
 792
 793             elsif C = 'Z' then
 794                Checkc ('X');
 795                   ALIs.Table (Id).Zero_Cost_Exceptions := True;
 796                   Zero_Cost_Exceptions_Specified := True;
 797
 798             else
 799                Fatal_Error;
 800             end if;
 801          end loop;
 802
 803          if not NS_Found then
 804             No_Normalize_Scalars_Specified := True;
 805          end if;
 806
 807          Skip_Eol;
 808       end if;
 809
 810       C := Getc;
 811
 812       --  Acquire first restrictions line
 813
 814       if C /= 'R' then
 815          Fatal_Error;
 816
 817       elsif Ignore ('R') then
 818          Skip_Line;
 819
 820       else
 821          Checkc (' ');
 822          Skip_Space;
 823
 824          for R in All_Boolean_Restrictions loop
 825             C := Getc;
 826
 827             case C is
 828                when 'v' =>
 829                   ALIs.Table (Id).Restrictions.Violated (R) := True;
 830                   Cumulative_Restrictions.Violated (R) := True;
 831
 832                when 'r' =>
 833                   ALIs.Table (Id).Restrictions.Set (R) := True;
 834                   Cumulative_Restrictions.Set (R) := True;
 835
 836                when 'n' =>
 837                   null;
 838
 839                when others =>
 840                   Fatal_Error;
 841             end case;
 842          end loop;
 843
 844          Skip_Eol;
 845       end if;
 846
 847       C := Getc;
 848
 849       --  See if we have a second R line
 850
 851       if C /= 'R' then
 852
 853          --  If not, just ignore, and leave the restrictions variables
 854          --  unchanged. This is useful for dealing with old format ALI
 855          --  files with only one R line (this can be removed later on,
 856          --  but is useful for transitional purposes).
 857
 858          null;
 859
 860          --  Here we have a second R line, ignore it if ignore flag set
 861
 862       elsif Ignore ('R') then
 863          Skip_Line;
 864          C := Getc;
 865
 866       --  Otherwise acquire second R line
 867
 868       else
 869          Checkc (' ');
 870          Skip_Space;
 871
 872          for RP in All_Parameter_Restrictions loop
 873
 874             --  Acquire restrictions pragma information
 875
 876             case Getc is
 877                when 'n' =>
 878                   null;
 879
 880                when 'r' =>
 881                   ALIs.Table (Id).Restrictions.Set (RP) := True;
 882
 883                   declare
 884                      N : constant Integer := Integer (Get_Nat);
 885                   begin
 886                      ALIs.Table (Id).Restrictions.Value (RP) := N;
 887
 888                      if Cumulative_Restrictions.Set (RP) then
 889                         Cumulative_Restrictions.Value (RP) :=
 890                           Integer'Min (Cumulative_Restrictions.Value (RP), N);
 891                      else
 892                         Cumulative_Restrictions.Set (RP) := True;
 893                         Cumulative_Restrictions.Value (RP) := N;
 894                      end if;
 895                   end;
 896
 897                when others =>
 898                   Fatal_Error;
 899             end case;
 900
 901             --  Acquire restrictions violations information
 902
 903             case Getc is
 904                when 'n' =>
 905                   null;
 906
 907                when 'v' =>
 908                   ALIs.Table (Id).Restrictions.Violated (RP) := True;
 909                   Cumulative_Restrictions.Violated (RP) := True;
 910
 911                   declare
 912                      N : constant Integer := Integer (Get_Nat);
 913                      pragma Unsuppress (Overflow_Check);
 914
 915                   begin
 916                      ALIs.Table (Id).Restrictions.Count (RP) := N;
 917
 918                      if RP in Checked_Max_Parameter_Restrictions then
 919                         Cumulative_Restrictions.Count (RP) :=
 920                           Integer'Max (Cumulative_Restrictions.Count (RP), N);
 921                      else
 922                         Cumulative_Restrictions.Count (RP) :=
 923                           Cumulative_Restrictions.Count (RP) + N;
 924                      end if;
 925
 926                   exception
 927                      when Constraint_Error =>
 928
 929                         --  A constraint error comes from the addition in
 930                         --  the else branch. We reset to the maximum and
 931                         --  indicate that the real value is now unknown.
 932
 933                         Cumulative_Restrictions.Value (RP) := Integer'Last;
 934                         Cumulative_Restrictions.Unknown (RP) := True;
 935                   end;
 936
 937                   if Nextc = '+' then
 938                      Skipc;
 939                      ALIs.Table (Id).Restrictions.Unknown (RP) := True;
 940                      Cumulative_Restrictions.Unknown (RP) := True;
 941                   end if;
 942
 943                when others =>
 944                   Fatal_Error;
 945             end case;
 946          end loop;
 947
 948          Skip_Eol;
 949          C := Getc;
 950       end if;
 951
 952       --  Acquire 'I' lines if present
 953
 954       while C = 'I' loop
 955          if Ignore ('I') then
 956             Skip_Line;
 957
 958          else
 959             declare
 960                Int_Num : Nat;
 961                I_State : Character;
 962                Line_No : Nat;
 963
 964             begin
 965                Int_Num := Get_Nat;
 966                Skip_Space;
 967                I_State := Getc;
 968                Line_No := Get_Nat;
 969
 970                Interrupt_States.Append (
 971                  (Interrupt_Id    => Int_Num,
 972                   Interrupt_State => I_State,
 973                   IS_Pragma_Line  => Line_No));
 974
 975                ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
 976                Skip_Eol;
 977             end;
 978          end if;
 979
 980          C := Getc;
 981       end loop;
 982
 983       --  Loop to acquire unit entries
 984
 985       Unit_Loop : while C = 'U' loop
 986
 987          --  Note: as per spec, we never ignore U lines
 988
 989          Checkc (' ');
 990          Skip_Space;
 991          Units.Increment_Last;
 992
 993          if ALIs.Table (Id).First_Unit = No_Unit_Id then
 994             ALIs.Table (Id).First_Unit := Units.Last;
 995          end if;
 996
 997          Units.Table (Units.Last).Uname           := Get_Name;
 998          Units.Table (Units.Last).Predefined      := Is_Predefined_Unit;
 999          Units.Table (Units.Last).Internal        := Is_Internal_Unit;
1000          Units.Table (Units.Last).My_ALI          := Id;
1001          Units.Table (Units.Last).Sfile           := Get_Name (Lower => True);
1002          Units.Table (Units.Last).Pure            := False;
1003          Units.Table (Units.Last).Preelab         := False;
1004          Units.Table (Units.Last).No_Elab         := False;
1005          Units.Table (Units.Last).Shared_Passive  := False;
1006          Units.Table (Units.Last).RCI             := False;
1007          Units.Table (Units.Last).Remote_Types    := False;
1008          Units.Table (Units.Last).Has_RACW        := False;
1009          Units.Table (Units.Last).Init_Scalars    := False;
1010          Units.Table (Units.Last).Is_Generic      := False;
1011          Units.Table (Units.Last).Icasing         := Mixed_Case;
1012          Units.Table (Units.Last).Kcasing         := All_Lower_Case;
1013          Units.Table (Units.Last).Dynamic_Elab    := False;
1014          Units.Table (Units.Last).Elaborate_Body  := False;
1015          Units.Table (Units.Last).Set_Elab_Entity := False;
1016          Units.Table (Units.Last).Version         := "00000000";
1017          Units.Table (Units.Last).First_With      := Withs.Last + 1;
1018          Units.Table (Units.Last).First_Arg       := First_Arg;
1019          Units.Table (Units.Last).Elab_Position   := 0;
1020          Units.Table (Units.Last).Interface       := ALIs.Table (Id).Interface;
1021
1022          if Debug_Flag_U then
1023             Write_Str (" ----> reading unit ");
1024             Write_Int (Int (Units.Last));
1025             Write_Str ("  ");
1026             Write_Unit_Name (Units.Table (Units.Last).Uname);
1027             Write_Str (" from file ");
1028             Write_Name (Units.Table (Units.Last).Sfile);
1029             Write_Eol;
1030          end if;
1031
1032          --  Check for duplicated unit in different files
1033
1034          declare
1035             Info : constant Int := Get_Name_Table_Info
1036                                      (Units.Table (Units.Last).Uname);
1037          begin
1038             if Info /= 0
1039               and then Units.Table (Units.Last).Sfile /=
1040                        Units.Table (Unit_Id (Info)).Sfile
1041             then
1042                --  If Err is set then ignore duplicate unit name. This is the
1043                --  case of a call from gnatmake, where the situation can arise
1044                --  from substitution of source files. In such situations, the
1045                --  processing in gnatmake will always result in any required
1046                --  recompilations in any case, and if we consider this to be
1047                --  an error we get strange cases (for example when a generic
1048                --  instantiation is replaced by a normal package) where we
1049                --  read the old ali file, decide to recompile, and then decide
1050                --  that the old and new ali files are incompatible.
1051
1052                if Err then
1053                   null;
1054
1055                --  If Err is not set, then this is a fatal error. This is
1056                --  the case of being called from the binder, where we must
1057                --  definitely diagnose this as an error.
1058
1059                else
1060                   Set_Standard_Error;
1061                   Write_Str ("error: duplicate unit name: ");
1062                   Write_Eol;
1063
1064                   Write_Str ("error: unit """);
1065                   Write_Unit_Name (Units.Table (Units.Last).Uname);
1066                   Write_Str (""" found in file """);
1067                   Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1068                   Write_Char ('"');
1069                   Write_Eol;
1070
1071                   Write_Str ("error: unit """);
1072                   Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1073                   Write_Str (""" found in file """);
1074                   Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1075                   Write_Char ('"');
1076                   Write_Eol;
1077
1078                   Exit_Program (E_Fatal);
1079                end if;
1080             end if;
1081          end;
1082
1083          Set_Name_Table_Info
1084            (Units.Table (Units.Last).Uname, Int (Units.Last));
1085
1086          --  Scan out possible version and other parameters
1087
1088          loop
1089             Skip_Space;
1090             exit when At_Eol;
1091             C := Getc;
1092
1093             --  Version field
1094
1095             if C in '0' .. '9' or else C in 'a' .. 'f' then
1096                Units.Table (Units.Last).Version (1) := C;
1097
1098                for J in 2 .. 8 loop
1099                   C := Getc;
1100                   Units.Table (Units.Last).Version (J) := C;
1101                end loop;
1102
1103             --  BN parameter (Body needed)
1104
1105             elsif C = 'B' then
1106                Checkc ('N');
1107                Check_At_End_Of_Field;
1108                Units.Table (Units.Last).Body_Needed_For_SAL := True;
1109
1110             --  DE parameter (Dynamic elaboration checks
1111
1112             elsif C = 'D' then
1113                Checkc ('E');
1114                Check_At_End_Of_Field;
1115                Units.Table (Units.Last).Dynamic_Elab := True;
1116                Dynamic_Elaboration_Checks_Specified := True;
1117
1118             --  EB/EE parameters
1119
1120             elsif C = 'E' then
1121                C := Getc;
1122
1123                if C = 'B' then
1124                   Units.Table (Units.Last).Elaborate_Body := True;
1125
1126                elsif C = 'E' then
1127                   Units.Table (Units.Last).Set_Elab_Entity := True;
1128
1129                else
1130                   Fatal_Error;
1131                end if;
1132
1133                Check_At_End_Of_Field;
1134
1135             --  GE parameter (generic)
1136
1137             elsif C = 'G' then
1138                Checkc ('E');
1139                Check_At_End_Of_Field;
1140                Units.Table (Units.Last).Is_Generic := True;
1141
1142             --  IL/IS/IU parameters
1143
1144             elsif C = 'I' then
1145                C := Getc;
1146
1147                if C = 'L' then
1148                   Units.Table (Units.Last).Icasing := All_Lower_Case;
1149
1150                elsif C = 'S' then
1151                   Units.Table (Units.Last).Init_Scalars := True;
1152                   Initialize_Scalars_Used := True;
1153
1154                elsif C = 'U' then
1155                   Units.Table (Units.Last).Icasing := All_Upper_Case;
1156
1157                else
1158                   Fatal_Error;
1159                end if;
1160
1161                Check_At_End_Of_Field;
1162
1163             --  KM/KU parameters
1164
1165             elsif C = 'K' then
1166                C := Getc;
1167
1168                if C = 'M' then
1169                   Units.Table (Units.Last).Kcasing := Mixed_Case;
1170
1171                elsif C = 'U' then
1172                   Units.Table (Units.Last).Kcasing := All_Upper_Case;
1173
1174                else
1175                   Fatal_Error;
1176                end if;
1177
1178                Check_At_End_Of_Field;
1179
1180             --  NE parameter
1181
1182             elsif C = 'N' then
1183                Checkc ('E');
1184                Units.Table (Units.Last).No_Elab := True;
1185                Check_At_End_Of_Field;
1186
1187             --  PR/PU/PK parameters
1188
1189             elsif C = 'P' then
1190                C := Getc;
1191
1192                --  PR parameter (preelaborate)
1193
1194                if C = 'R' then
1195                   Units.Table (Units.Last).Preelab := True;
1196
1197                --  PU parameter (pure)
1198
1199                elsif C = 'U' then
1200                   Units.Table (Units.Last).Pure := True;
1201
1202                --  PK indicates unit is package
1203
1204                elsif C = 'K' then
1205                   Units.Table (Units.Last).Unit_Kind := 'p';
1206
1207                else
1208                   Fatal_Error;
1209                end if;
1210
1211                Check_At_End_Of_Field;
1212
1213             --  RC/RT parameters
1214
1215             elsif C = 'R' then
1216                C := Getc;
1217
1218                --  RC parameter (remote call interface)
1219
1220                if C = 'C' then
1221                   Units.Table (Units.Last).RCI := True;
1222
1223                --  RT parameter (remote types)
1224
1225                elsif C = 'T' then
1226                   Units.Table (Units.Last).Remote_Types := True;
1227
1228                --  RA parameter (remote access to class wide type)
1229
1230                elsif C = 'A' then
1231                   Units.Table (Units.Last).Has_RACW := True;
1232
1233                else
1234                   Fatal_Error;
1235                end if;
1236
1237                Check_At_End_Of_Field;
1238
1239             elsif C = 'S' then
1240                C := Getc;
1241
1242                --  SP parameter (shared passive)
1243
1244                if C = 'P' then
1245                   Units.Table (Units.Last).Shared_Passive := True;
1246
1247                --  SU parameter indicates unit is subprogram
1248
1249                elsif C = 'U' then
1250                   Units.Table (Units.Last).Unit_Kind := 's';
1251
1252                else
1253                   Fatal_Error;
1254                end if;
1255
1256                Check_At_End_Of_Field;
1257
1258             else
1259                Fatal_Error;
1260             end if;
1261          end loop;
1262
1263          Skip_Eol;
1264
1265          --  Check if static elaboration model used
1266
1267          if not Units.Table (Units.Last).Dynamic_Elab
1268            and then not Units.Table (Units.Last).Internal
1269          then
1270             Static_Elaboration_Model_Used := True;
1271          end if;
1272
1273          C := Getc;
1274
1275          --  Scan out With lines for this unit
1276
1277          With_Loop : while C = 'W' loop
1278             if Ignore ('W') then
1279                Skip_Line;
1280
1281             else
1282                Checkc (' ');
1283                Skip_Space;
1284                Withs.Increment_Last;
1285                Withs.Table (Withs.Last).Uname              := Get_Name;
1286                Withs.Table (Withs.Last).Elaborate          := False;
1287                Withs.Table (Withs.Last).Elaborate_All      := False;
1288                Withs.Table (Withs.Last).Elab_All_Desirable := False;
1289                Withs.Table (Withs.Last).Interface          := False;
1290
1291                --  Generic case with no object file available
1292
1293                if At_Eol then
1294                   Withs.Table (Withs.Last).Sfile := No_File;
1295                   Withs.Table (Withs.Last).Afile := No_File;
1296
1297                --  Normal case
1298
1299                else
1300                   Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
1301                   Withs.Table (Withs.Last).Afile := Get_Name;
1302
1303                   --  Scan out possible E, EA, and NE parameters
1304
1305                   while not At_Eol loop
1306                      Skip_Space;
1307
1308                      if Nextc = 'E' then
1309                         P := P + 1;
1310
1311                         if At_End_Of_Field then
1312                            Withs.Table (Withs.Last).Elaborate := True;
1313
1314                         elsif Nextc = 'A' then
1315                            P := P + 1;
1316                            Check_At_End_Of_Field;
1317                            Withs.Table (Withs.Last).Elaborate_All := True;
1318
1319                         else
1320                            Checkc ('D');
1321                            Check_At_End_Of_Field;
1322
1323                            --  Store ED indication unless ignore required
1324
1325                            if not Ignore_ED then
1326                               Withs.Table (Withs.Last).Elab_All_Desirable :=
1327                                 True;
1328                            end if;
1329                         end if;
1330                      end if;
1331                   end loop;
1332                end if;
1333
1334                Skip_Eol;
1335             end if;
1336
1337             C := Getc;
1338          end loop With_Loop;
1339
1340          Units.Table (Units.Last).Last_With := Withs.Last;
1341          Units.Table (Units.Last).Last_Arg  := Args.Last;
1342
1343          --  If there are linker options lines present, scan them
1344
1345          Name_Len := 0;
1346
1347          Linker_Options_Loop : while C = 'L' loop
1348
1349             if Ignore ('L') then
1350                Skip_Line;
1351
1352             else
1353                Checkc (' ');
1354                Skip_Space;
1355                Checkc ('"');
1356
1357                loop
1358                   C := Getc;
1359
1360                   if C < Character'Val (16#20#)
1361                     or else C > Character'Val (16#7E#)
1362                   then
1363                      Fatal_Error;
1364
1365                   elsif C = '{' then
1366                      C := Character'Val (0);
1367
1368                      declare
1369                         V : Natural;
1370
1371                      begin
1372                         V := 0;
1373                         for J in 1 .. 2 loop
1374                            C := Getc;
1375
1376                            if C in '0' .. '9' then
1377                               V := V * 16 +
1378                                      Character'Pos (C) -
1379                                        Character'Pos ('0');
1380
1381                            elsif C in 'A' .. 'F' then
1382                               V := V * 16 +
1383                                      Character'Pos (C) -
1384                                        Character'Pos ('A') +
1385                                          10;
1386
1387                            else
1388                               Fatal_Error;
1389                            end if;
1390                         end loop;
1391
1392                         Checkc ('}');
1393                         Add_Char_To_Name_Buffer (Character'Val (V));
1394                      end;
1395
1396                   else
1397                      if C = '"' then
1398                         exit when Nextc /= '"';
1399                         C := Getc;
1400                      end if;
1401
1402                      Add_Char_To_Name_Buffer (C);
1403                   end if;
1404                end loop;
1405
1406                Add_Char_To_Name_Buffer (nul);
1407                Skip_Eol;
1408             end if;
1409
1410             C := Getc;
1411          end loop Linker_Options_Loop;
1412
1413          --  Store the linker options entry if one was found
1414
1415          if Name_Len /= 0 then
1416             Linker_Options.Increment_Last;
1417
1418             Linker_Options.Table (Linker_Options.Last).Name :=
1419               Name_Enter;
1420
1421             Linker_Options.Table (Linker_Options.Last).Unit :=
1422               Units.Last;
1423
1424             Linker_Options.Table (Linker_Options.Last).Internal_File :=
1425               Is_Internal_File_Name (F);
1426
1427             Linker_Options.Table (Linker_Options.Last).Original_Pos :=
1428               Linker_Options.Last;
1429          end if;
1430       end loop Unit_Loop;
1431
1432       --  End loop through units for one ALI file
1433
1434       ALIs.Table (Id).Last_Unit := Units.Last;
1435       ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
1436
1437       --  Set types of the units (there can be at most 2 of them)
1438
1439       if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
1440          Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
1441          Units.Table (ALIs.Table (Id).Last_Unit).Utype  := Is_Spec;
1442
1443       else
1444          --  Deal with body only and spec only cases, note that the reason we
1445          --  do our own checking of the name (rather than using Is_Body_Name)
1446          --  is that Uname drags in far too much compiler junk!
1447
1448          Get_Name_String (Units.Table (Units.Last).Uname);
1449
1450          if Name_Buffer (Name_Len) = 'b' then
1451             Units.Table (Units.Last).Utype := Is_Body_Only;
1452          else
1453             Units.Table (Units.Last).Utype := Is_Spec_Only;
1454          end if;
1455       end if;
1456
1457       --  Scan out external version references and put in hash table
1458
1459       while C = 'E' loop
1460          if Ignore ('E') then
1461             Skip_Line;
1462
1463          else
1464             Checkc (' ');
1465             Skip_Space;
1466
1467             Name_Len := 0;
1468             Name_Len := 0;
1469             loop
1470                C := Getc;
1471
1472                if C < ' ' then
1473                   Fatal_Error;
1474                end if;
1475
1476                exit when At_End_Of_Field;
1477                Add_Char_To_Name_Buffer (C);
1478             end loop;
1479
1480             Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
1481             Skip_Eol;
1482          end if;
1483
1484          C := Getc;
1485       end loop;
1486
1487       --  Scan out source dependency lines for this ALI file
1488
1489       ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
1490
1491       while C = 'D' loop
1492          if Ignore ('D') then
1493             Skip_Line;
1494
1495          else
1496             Checkc (' ');
1497             Skip_Space;
1498             Sdep.Increment_Last;
1499             Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
1500             Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
1501             Sdep.Table (Sdep.Last).Dummy_Entry :=
1502               (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
1503
1504             --  Acquire checksum value
1505
1506             Skip_Space;
1507
1508             declare
1509                Ctr : Natural;
1510                Chk : Word;
1511
1512             begin
1513                Ctr := 0;
1514                Chk := 0;
1515
1516                loop
1517                   exit when At_Eol or else Ctr = 8;
1518
1519                   if Nextc in '0' .. '9' then
1520                      Chk := Chk * 16 +
1521                               Character'Pos (Nextc) - Character'Pos ('0');
1522
1523                   elsif Nextc in 'a' .. 'f' then
1524                      Chk := Chk * 16 +
1525                               Character'Pos (Nextc) - Character'Pos ('a') + 10;
1526
1527                   else
1528                      exit;
1529                   end if;
1530
1531                   Ctr := Ctr + 1;
1532                   P := P + 1;
1533                end loop;
1534
1535                if Ctr = 8 and then At_End_Of_Field then
1536                   Sdep.Table (Sdep.Last).Checksum := Chk;
1537                else
1538                   Fatal_Error;
1539                end if;
1540             end;
1541
1542             --  Acquire subunit and reference file name entries
1543
1544             Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
1545             Sdep.Table (Sdep.Last).Rfile        :=
1546               Sdep.Table (Sdep.Last).Sfile;
1547             Sdep.Table (Sdep.Last).Start_Line   := 1;
1548
1549             if not At_Eol then
1550                Skip_Space;
1551
1552                --  Here for subunit name
1553
1554                if Nextc not in '0' .. '9' then
1555                   Name_Len := 0;
1556
1557                   while not At_End_Of_Field loop
1558                      Name_Len := Name_Len + 1;
1559                      Name_Buffer (Name_Len) := Getc;
1560                   end loop;
1561
1562                   Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
1563                   Skip_Space;
1564                end if;
1565
1566                --  Here for reference file name entry
1567
1568                if Nextc in '0' .. '9' then
1569                   Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
1570                   Checkc (':');
1571
1572                   Name_Len := 0;
1573
1574                   while not At_End_Of_Field loop
1575                      Name_Len := Name_Len + 1;
1576                      Name_Buffer (Name_Len) := Getc;
1577                   end loop;
1578
1579                   Sdep.Table (Sdep.Last).Rfile := Name_Enter;
1580                end if;
1581             end if;
1582
1583             Skip_Eol;
1584          end if;
1585
1586          C := Getc;
1587       end loop;
1588
1589       ALIs.Table (Id).Last_Sdep := Sdep.Last;
1590
1591       --  We must at this stage be at an Xref line or the end of file
1592
1593       if C /= EOF and then C /= 'X' then
1594          Fatal_Error;
1595       end if;
1596
1597       --  If we are ignoring Xref sections we are done (we ignore all
1598       --  remaining lines since only xref related lines follow X).
1599
1600       if Ignore ('X') and then not Debug_Flag_X then
1601          return Id;
1602       end if;
1603
1604       --  Loop through Xref sections
1605
1606       while C = 'X' loop
1607
1608          --  Make new entry in section table
1609
1610          Xref_Section.Increment_Last;
1611
1612          Read_Refs_For_One_File : declare
1613             XS : Xref_Section_Record renames
1614                    Xref_Section.Table (Xref_Section.Last);
1615
1616             Current_File_Num : Sdep_Id;
1617             --  Keeps track of the current file number (changed by nn|)
1618
1619          begin
1620             XS.File_Num     := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
1621             XS.File_Name    := Get_Name;
1622             XS.First_Entity := Xref_Entity.Last + 1;
1623
1624             Current_File_Num := XS.File_Num;
1625
1626             Skip_Space;
1627
1628             Skip_Eol;
1629             C := Nextc;
1630
1631             --  Loop through Xref entities
1632
1633             while C /= 'X' and then C /= EOF loop
1634                Xref_Entity.Increment_Last;
1635
1636                Read_Refs_For_One_Entity : declare
1637                   XE : Xref_Entity_Record renames
1638                          Xref_Entity.Table (Xref_Entity.Last);
1639                   N  : Nat;
1640
1641                   procedure Read_Instantiation_Reference;
1642                   --  Acquire instantiation reference. Caller has checked
1643                   --  that current character is '[' and on return the cursor
1644                   --  is skipped past the corresponding closing ']'.
1645
1646                   ----------------------------------
1647                   -- Read_Instantiation_Reference --
1648                   ----------------------------------
1649
1650                   procedure Read_Instantiation_Reference is
1651                   begin
1652                      Xref.Increment_Last;
1653
1654                      declare
1655                         XR : Xref_Record renames Xref.Table (Xref.Last);
1656
1657                      begin
1658                         P := P + 1; -- skip [
1659                         N := Get_Nat;
1660
1661                         if Nextc = '|' then
1662                            XR.File_Num :=
1663                              Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1664                            Current_File_Num := XR.File_Num;
1665                            P := P + 1;
1666                            N := Get_Nat;
1667
1668                         else
1669                            XR.File_Num := Current_File_Num;
1670                         end if;
1671
1672                         XR.Line  := N;
1673                         XR.Rtype := ' ';
1674                         XR.Col   := 0;
1675
1676                         --  Recursive call for next reference
1677
1678                         if Nextc = '[' then
1679                            pragma Warnings (Off); -- kill recursion warning
1680                            Read_Instantiation_Reference;
1681                            pragma Warnings (On);
1682                         end if;
1683
1684                         --  Skip closing bracket after recursive call
1685
1686                         P := P + 1;
1687                      end;
1688                   end Read_Instantiation_Reference;
1689
1690                --  Start of processing for Read_Refs_For_One_Entity
1691
1692                begin
1693                   XE.Line   := Get_Nat;
1694                   XE.Etype  := Getc;
1695                   XE.Col    := Get_Nat;
1696                   XE.Lib    := (Getc = '*');
1697                   XE.Entity := Get_Name;
1698
1699                   Current_File_Num := XS.File_Num;
1700
1701                   --  Renaming reference is present
1702
1703                   if Nextc = '=' then
1704                      P := P + 1;
1705                      XE.Rref_Line := Get_Nat;
1706
1707                      if Getc /= ':' then
1708                         Fatal_Error;
1709                      end if;
1710
1711                      XE.Rref_Col := Get_Nat;
1712
1713                   --  No renaming reference present
1714
1715                   else
1716                      XE.Rref_Line := 0;
1717                      XE.Rref_Col  := 0;
1718                   end if;
1719
1720                   Skip_Space;
1721
1722                   --  See if type reference present
1723
1724                   case Nextc is
1725                      when '<'    => XE.Tref := Tref_Derived;
1726                      when '('    => XE.Tref := Tref_Access;
1727                      when '{'    => XE.Tref := Tref_Type;
1728                      when others => XE.Tref := Tref_None;
1729                   end case;
1730
1731                   --  Case of typeref field present
1732
1733                   if XE.Tref /= Tref_None then
1734                      P := P + 1; -- skip opening bracket
1735
1736                      if Nextc in 'a' .. 'z' then
1737                         XE.Tref_File_Num        := No_Sdep_Id;
1738                         XE.Tref_Line            := 0;
1739                         XE.Tref_Type            := ' ';
1740                         XE.Tref_Col             := 0;
1741                         XE.Tref_Standard_Entity :=
1742                           Get_Name (Ignore_Spaces => True);
1743
1744                      else
1745                         N := Get_Nat;
1746
1747                         if Nextc = '|' then
1748                            XE.Tref_File_Num :=
1749                              Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1750                            P := P + 1;
1751                            N := Get_Nat;
1752
1753                         else
1754                            XE.Tref_File_Num := Current_File_Num;
1755                         end if;
1756
1757                         XE.Tref_Line            := N;
1758                         XE.Tref_Type            := Getc;
1759                         XE.Tref_Col             := Get_Nat;
1760                         XE.Tref_Standard_Entity := No_Name;
1761                      end if;
1762
1763                      --  ??? Temporary workaround for nested generics case:
1764                      --     4i4 Directories{1|4I9[4|6[3|3]]}
1765                      --  See C918-002
1766
1767                      declare
1768                         Nested_Brackets : Natural := 0;
1769
1770                      begin
1771                         loop
1772                            case Nextc is
1773                               when '['   =>
1774                                  Nested_Brackets := Nested_Brackets + 1;
1775                               when ']' =>
1776                                  Nested_Brackets := Nested_Brackets - 1;
1777                               when others =>
1778                                  if Nested_Brackets = 0 then
1779                                     exit;
1780                                  end if;
1781                            end case;
1782
1783                            Skipc;
1784                         end loop;
1785                      end;
1786
1787                      P := P + 1; -- skip closing bracket
1788                      Skip_Space;
1789
1790                   --  No typeref entry present
1791
1792                   else
1793                      XE.Tref_File_Num        := No_Sdep_Id;
1794                      XE.Tref_Line            := 0;
1795                      XE.Tref_Type            := ' ';
1796                      XE.Tref_Col             := 0;
1797                      XE.Tref_Standard_Entity := No_Name;
1798                   end if;
1799
1800                   XE.First_Xref := Xref.Last + 1;
1801
1802                   --  Loop through cross-references for this entity
1803
1804                   loop
1805                      Skip_Space;
1806
1807                      if At_Eol then
1808                         Skip_Eol;
1809                         exit when Nextc /= '.';
1810                         P := P + 1;
1811                      end if;
1812
1813                      Xref.Increment_Last;
1814
1815                      declare
1816                         XR : Xref_Record renames Xref.Table (Xref.Last);
1817
1818                      begin
1819                         N := Get_Nat;
1820
1821                         if Nextc = '|' then
1822                            XR.File_Num :=
1823                              Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1824                            Current_File_Num := XR.File_Num;
1825                            P := P + 1;
1826                            N := Get_Nat;
1827                         else
1828                            XR.File_Num := Current_File_Num;
1829                         end if;
1830
1831                         XR.Line  := N;
1832                         XR.Rtype := Getc;
1833
1834                         --  Imported entities reference as in:
1835                         --    494b<c,__gnat_copy_attribs>25
1836                         --  ??? Simply skipped for now
1837
1838                         if Nextc = '<' then
1839                            while Getc /= '>' loop
1840                               null;
1841                            end loop;
1842                         end if;
1843
1844                         XR.Col   := Get_Nat;
1845
1846                         if Nextc = '[' then
1847                            Read_Instantiation_Reference;
1848                         end if;
1849                      end;
1850                   end loop;
1851
1852                   --  Record last cross-reference
1853
1854                   XE.Last_Xref := Xref.Last;
1855                   C := Nextc;
1856                end Read_Refs_For_One_Entity;
1857             end loop;
1858
1859             --  Record last entity
1860
1861             XS.Last_Entity := Xref_Entity.Last;
1862
1863          end Read_Refs_For_One_File;
1864
1865          C := Getc;
1866       end loop;
1867
1868       --  Here after dealing with xref sections
1869
1870       if C /= EOF and then C /= 'X' then
1871          Fatal_Error;
1872       end if;
1873
1874       return Id;
1875
1876    exception
1877       when Bad_ALI_Format =>
1878          return No_ALI_Id;
1879
1880    end Scan_ALI;
1881
1882    ---------
1883    -- SEq --
1884    ---------
1885
1886    function SEq (F1, F2 : String_Ptr) return Boolean is
1887    begin
1888       return F1.all = F2.all;
1889    end SEq;
1890
1891    -----------
1892    -- SHash --
1893    -----------
1894
1895    function SHash (S : String_Ptr) return Vindex is
1896       H : Word;
1897
1898    begin
1899       H := 0;
1900       for J in S.all'Range loop
1901          H := H * 2 + Character'Pos (S (J));
1902       end loop;
1903
1904       return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
1905    end SHash;
1906
1907 end ALI;