gcc/ada/ali.adb

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