gcc/ada/ali.adb

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