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