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