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