gcc/ada/ali.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  A L I                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Butil;  use Butil;
  28 with Debug;  use Debug;
  29 with Fname;  use Fname;
  30 with Namet;  use Namet;
  31 with Opt;    use Opt;
  32 with Osint;  use Osint;
  33 with Output; use Output;
  34
  35 package body ALI is
  36
  37    use ASCII;
  38    --  Make control characters visible
  39
  40    --  The following variable records which characters currently are
  41    --  used as line type markers in the ALI file. This is used in
  42    --  Scan_ALI to detect (or skip) invalid lines.
  43
  44    Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
  45      ('V'    => True,   -- version
  46       'M'    => True,   -- main program
  47       'A'    => True,   -- argument
  48       'P'    => True,   -- program
  49       'R'    => True,   -- restriction
  50       'I'    => True,   -- interrupt
  51       'U'    => True,   -- unit
  52       'W'    => True,   -- with
  53       'L'    => True,   -- linker option
  54       'E'    => True,   -- external
  55       'D'    => True,   -- dependency
  56       'X'    => True,   -- xref
  57       others => False);
  58
  59    --------------------
  60    -- Initialize_ALI --
  61    --------------------
  62
  63    procedure Initialize_ALI is
  64    begin
  65       --  When (re)initializing ALI data structures the ALI user expects to
  66       --  get a fresh set of data structures. Thus we first need to erase the
  67       --  marks put in the name table by the previous set of ALI routine calls.
  68       --  These two loops are empty and harmless the first time in.
  69
  70       for J in ALIs.First .. ALIs.Last loop
  71          Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
  72       end loop;
  73
  74       for J in Units.First .. Units.Last loop
  75          Set_Name_Table_Info (Units.Table (J).Uname, 0);
  76       end loop;
  77
  78       --  Free argument table strings
  79
  80       for J in Args.First .. Args.Last loop
  81          Free (Args.Table (J));
  82       end loop;
  83
  84       --  Initialize all tables
  85
  86       ALIs.Init;
  87       No_Deps.Init;
  88       Units.Init;
  89       Withs.Init;
  90       Sdep.Init;
  91       Linker_Options.Init;
  92       Xref_Section.Init;
  93       Xref_Entity.Init;
  94       Xref.Init;
  95       Version_Ref.Reset;
  96
  97       --  Add dummy zero'th item in Linker_Options for the sort function
  98
  99       Linker_Options.Increment_Last;
 100
 101       --  Initialize global variables recording cumulative options in all
 102       --  ALI files that are read for a given processing run in gnatbind.
 103
 104       Dynamic_Elaboration_Checks_Specified := False;
 105       Float_Format_Specified               := ' ';
 106       Locking_Policy_Specified             := ' ';
 107       No_Normalize_Scalars_Specified       := False;
 108       No_Object_Specified                  := False;
 109       Normalize_Scalars_Specified          := False;
 110       Queuing_Policy_Specified             := ' ';
 111       Static_Elaboration_Model_Used        := False;
 112       Task_Dispatching_Policy_Specified    := ' ';
 113       Unreserve_All_Interrupts_Specified   := False;
 114       Zero_Cost_Exceptions_Specified       := False;
 115    end Initialize_ALI;
 116
 117    --------------
 118    -- Scan_ALI --
 119    --------------
 120
 121    function Scan_ALI
 122      (F             : File_Name_Type;
 123       T             : Text_Buffer_Ptr;
 124       Ignore_ED     : Boolean;
 125       Err           : Boolean;
 126       Read_Xref     : Boolean := False;
 127       Read_Lines    : String  := "";
 128       Ignore_Lines  : String  := "X";
 129       Ignore_Errors : Boolean := False) return ALI_Id
 130    is
 131       P         : Text_Ptr := T'First;
 132       Line      : Logical_Line_Number := 1;
 133       Id        : ALI_Id;
 134       C         : Character;
 135       NS_Found  : Boolean;
 136       First_Arg : Arg_Id;
 137
 138       Ignore : array (Character range 'A' .. 'Z') of Boolean;
 139       --  Ignore (X) is set to True if lines starting with X are to
 140       --  be ignored by Scan_ALI and skipped, and False if the lines
 141       --  are to be read and processed.
 142
 143       Restrictions_Initial : Rident.Restrictions_Info;
 144       pragma Warnings (Off, Restrictions_Initial);
 145       --  This variable, which should really be a constant (but that's not
 146       --  allowed by the language) is used only for initialization, and the
 147       --  reason we are declaring it is to get the default initialization
 148       --  set for the object.
 149
 150       Bad_ALI_Format : exception;
 151       --  Exception raised by Fatal_Error if Err is True
 152
 153       function At_Eol return Boolean;
 154       --  Test if at end of line
 155
 156       function At_End_Of_Field return Boolean;
 157       --  Test if at end of line, or if at blank or horizontal tab
 158
 159       procedure Check_At_End_Of_Field;
 160       --  Check if we are at end of field, fatal error if not
 161
 162       procedure Checkc (C : Character);
 163       --  Check next character is C. If so bump past it, if not fatal error
 164
 165       procedure Check_Unknown_Line;
 166       --  If Ignore_Errors mode, then checks C to make sure that it is not
 167       --  an unknown ALI line type characters, and if so, skips lines
 168       --  until the first character of the line is one of these characters,
 169       --  at which point it does a Getc to put that character in C. The
 170       --  call has no effect if C is already an appropriate character.
 171       --  If not in Ignore_Errors mode, a fatal error is signalled if the
 172       --  line is unknown. Note that if C is an EOL on entry, the line is
 173       --  skipped (it is assumed that blank lines are never significant).
 174       --  If C is EOF on entry, the call has no effect (it is assumed that
 175       --  the caller will properly handle this case).
 176
 177       procedure Fatal_Error;
 178       --  Generate fatal error message for badly formatted ALI file if
 179       --  Err is false, or raise Bad_ALI_Format if Err is True.
 180
 181       procedure Fatal_Error_Ignore;
 182       pragma Inline (Fatal_Error_Ignore);
 183       --  In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
 184
 185       function Getc return Character;
 186       --  Get next character, bumping P past the character obtained
 187
 188       function Get_Name
 189         (Lower         : Boolean := False;
 190          Ignore_Spaces : Boolean := False) return Name_Id;
 191       --  Skip blanks, then scan out a name (name is left in Name_Buffer with
 192       --  length in Name_Len, as well as being returned in Name_Id form).
 193       --  If Lower is set to True then the Name_Buffer will be converted to
 194       --  all lower case, for systems where file names are not case sensitive.
 195       --  This ensures that gnatbind works correctly regardless of the case
 196       --  of the file name on all systems. The name is terminated by a either
 197       --  white space (when Ignore_Spaces is False) or a typeref bracket or
 198       --  an equal sign except for the special case of an operator name
 199       --  starting with a double quite which is terminated by another double
 200       --  quote.
 201
 202       function Get_Nat return Nat;
 203       --  Skip blanks, then scan out an unsigned integer value in Nat range
 204
 205       function Get_Stamp return Time_Stamp_Type;
 206       --  Skip blanks, then scan out a time stamp
 207
 208       function Nextc return Character;
 209       --  Return current character without modifying pointer P
 210
 211       procedure Skip_Eol;
 212       --  Skip past spaces, then skip past end of line (fatal error if not
 213       --  at end of line). Also skips past any following blank lines.
 214
 215       procedure Skip_Line;
 216       --  Skip rest of current line and any following blank lines
 217
 218       procedure Skip_Space;
 219       --  Skip past white space (blanks or horizontal tab)
 220
 221       procedure Skipc;
 222       --  Skip past next character, does not affect value in C. This call
 223       --  is like calling Getc and ignoring the returned result.
 224
 225       ---------------------
 226       -- At_End_Of_Field --
 227       ---------------------
 228
 229       function At_End_Of_Field return Boolean is
 230       begin
 231          return Nextc <= ' ';
 232       end At_End_Of_Field;
 233
 234       ------------
 235       -- At_Eol --
 236       ------------
 237
 238       function At_Eol return Boolean is
 239       begin
 240          return Nextc = EOF or else Nextc = CR or else Nextc = LF;
 241       end At_Eol;
 242
 243       ---------------------------
 244       -- Check_At_End_Of_Field --
 245       ---------------------------
 246
 247       procedure Check_At_End_Of_Field is
 248       begin
 249          if not At_End_Of_Field then
 250             if Ignore_Errors then
 251                while Nextc > ' ' loop
 252                   P := P + 1;
 253                end loop;
 254             else
 255                Fatal_Error;
 256             end if;
 257          end if;
 258       end Check_At_End_Of_Field;
 259
 260       ------------
 261       -- Checkc --
 262       ------------
 263
 264       procedure Checkc (C : Character) is
 265       begin
 266          if Nextc = C then
 267             P := P + 1;
 268          elsif Ignore_Errors then
 269             P := P + 1;
 270          else
 271             Fatal_Error;
 272          end if;
 273       end Checkc;
 274
 275       ------------------------
 276       -- Check_Unknown_Line --
 277       ------------------------
 278
 279       procedure Check_Unknown_Line is
 280       begin
 281          while C not in 'A' .. 'Z'
 282            or else not Known_ALI_Lines (C)
 283          loop
 284             if C = CR or else C = LF then
 285                Skip_Line;
 286                C := Nextc;
 287
 288             elsif C = EOF then
 289                return;
 290
 291             elsif Ignore_Errors then
 292                Skip_Line;
 293                C := Getc;
 294
 295             else
 296                Fatal_Error;
 297             end if;
 298          end loop;
 299       end Check_Unknown_Line;
 300
 301       -----------------
 302       -- Fatal_Error --
 303       -----------------
 304
 305       procedure Fatal_Error is
 306          Ptr1 : Text_Ptr;
 307          Ptr2 : Text_Ptr;
 308          Col  : Int;
 309
 310          procedure Wchar (C : Character);
 311          --  Write a single character, replacing horizontal tab by spaces
 312
 313          procedure Wchar (C : Character) is
 314          begin
 315             if C = HT then
 316                loop
 317                   Wchar (' ');
 318                   exit when Col mod 8 = 0;
 319                end loop;
 320
 321             else
 322                Write_Char (C);
 323                Col := Col + 1;
 324             end if;
 325          end Wchar;
 326
 327       --  Start of processing for Fatal_Error
 328
 329       begin
 330          if Err then
 331             raise Bad_ALI_Format;
 332          end if;
 333
 334          Set_Standard_Error;
 335          Write_Str ("fatal error: file ");
 336          Write_Name (F);
 337          Write_Str (" is incorrectly formatted");
 338          Write_Eol;
 339          Write_Str
 340            ("make sure you are using consistent versions of gcc/gnatbind");
 341          Write_Eol;
 342
 343          --  Find start of line
 344
 345          Ptr1 := P;
 346
 347          while Ptr1 > T'First
 348            and then T (Ptr1 - 1) /= CR
 349            and then T (Ptr1 - 1) /= LF
 350          loop
 351             Ptr1 := Ptr1 - 1;
 352          end loop;
 353
 354          Write_Int (Int (Line));
 355          Write_Str (". ");
 356
 357          if Line < 100 then
 358             Write_Char (' ');
 359          end if;
 360
 361          if Line < 10 then
 362             Write_Char (' ');
 363          end if;
 364
 365          Col := 0;
 366          Ptr2 := Ptr1;
 367
 368          while Ptr2 < T'Last
 369            and then T (Ptr2) /= CR
 370            and then T (Ptr2) /= LF
 371          loop
 372             Wchar (T (Ptr2));
 373             Ptr2 := Ptr2 + 1;
 374          end loop;
 375
 376          Write_Eol;
 377
 378          Write_Str ("     ");
 379          Col := 0;
 380
 381          while Ptr1 < P loop
 382             if T (Ptr1) = HT then
 383                Wchar (HT);
 384             else
 385                Wchar (' ');
 386             end if;
 387
 388             Ptr1 := Ptr1 + 1;
 389          end loop;
 390
 391          Wchar ('|');
 392          Write_Eol;
 393
 394          Exit_Program (E_Fatal);
 395       end Fatal_Error;
 396
 397       ------------------------
 398       -- Fatal_Error_Ignore --
 399       ------------------------
 400
 401       procedure Fatal_Error_Ignore is
 402       begin
 403          if not Ignore_Errors then
 404             Fatal_Error;
 405          end if;
 406       end Fatal_Error_Ignore;
 407
 408       --------------
 409       -- Get_Name --
 410       --------------
 411
 412       function Get_Name
 413         (Lower         : Boolean := False;
 414          Ignore_Spaces : Boolean := False) return Name_Id
 415       is
 416       begin
 417          Name_Len := 0;
 418          Skip_Space;
 419
 420          if At_Eol then
 421             if Ignore_Errors then
 422                return Error_Name;
 423             else
 424                Fatal_Error;
 425             end if;
 426          end if;
 427
 428          loop
 429             Name_Len := Name_Len + 1;
 430             Name_Buffer (Name_Len) := Getc;
 431
 432             exit when At_End_Of_Field and not Ignore_Spaces;
 433
 434             if Name_Buffer (1) = '"' then
 435                exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
 436
 437             else
 438                exit when (At_End_Of_Field and not Ignore_Spaces)
 439                  or else Nextc = '(' or else Nextc = ')'
 440                  or else Nextc = '{' or else Nextc = '}'
 441                  or else Nextc = '<' or else Nextc = '>'
 442                  or else Nextc = '=';
 443             end if;
 444          end loop;
 445
 446          --  Convert file name to all lower case if file names are not case
 447          --  sensitive. This ensures that we handle names in the canonical
 448          --  lower case format, regardless of the actual case.
 449
 450          if Lower and not File_Names_Case_Sensitive then
 451             Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
 452          end if;
 453
 454          return Name_Find;
 455       end Get_Name;
 456
 457       -------------
 458       -- Get_Nat --
 459       -------------
 460
 461       function Get_Nat return Nat is
 462          V : Nat;
 463
 464       begin
 465          Skip_Space;
 466
 467          V := 0;
 468          loop
 469             V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
 470             exit when At_End_Of_Field;
 471             exit when Nextc < '0' or Nextc > '9';
 472          end loop;
 473
 474          return V;
 475       end Get_Nat;
 476
 477       ---------------
 478       -- Get_Stamp --
 479       ---------------
 480
 481       function Get_Stamp return Time_Stamp_Type is
 482          T     : Time_Stamp_Type;
 483          Start : Integer;
 484
 485       begin
 486          Skip_Space;
 487
 488          if At_Eol then
 489             if Ignore_Errors then
 490                return Dummy_Time_Stamp;
 491             else
 492                Fatal_Error;
 493             end if;
 494          end if;
 495
 496          --  Following reads old style time stamp missing first two digits
 497
 498          if Nextc in '7' .. '9' then
 499             T (1) := '1';
 500             T (2) := '9';
 501             Start := 3;
 502
 503          --  Normal case of full year in time stamp
 504
 505          else
 506             Start := 1;
 507          end if;
 508
 509          for J in Start .. T'Last loop
 510             T (J) := Getc;
 511          end loop;
 512
 513          return T;
 514       end Get_Stamp;
 515
 516       ----------
 517       -- Getc --
 518       ----------
 519
 520       function Getc return Character is
 521       begin
 522          if P = T'Last then
 523             return EOF;
 524          else
 525             P := P + 1;
 526             return T (P - 1);
 527          end if;
 528       end Getc;
 529
 530       -----------
 531       -- Nextc --
 532       -----------
 533
 534       function Nextc return Character is
 535       begin
 536          return T (P);
 537       end Nextc;
 538
 539       --------------
 540       -- Skip_Eol --
 541       --------------
 542
 543       procedure Skip_Eol is
 544       begin
 545          Skip_Space;
 546
 547          if not At_Eol then
 548             if Ignore_Errors then
 549                while not At_Eol loop
 550                   P := P + 1;
 551                end loop;
 552             else
 553                Fatal_Error;
 554             end if;
 555          end if;
 556
 557          --  Loop to skip past blank lines (first time through skips this EOL)
 558
 559          while Nextc < ' ' and then Nextc /= EOF loop
 560             if Nextc = LF then
 561                Line := Line + 1;
 562             end if;
 563
 564             P := P + 1;
 565          end loop;
 566       end Skip_Eol;
 567
 568       ---------------
 569       -- Skip_Line --
 570       ---------------
 571
 572       procedure Skip_Line is
 573       begin
 574          while not At_Eol loop
 575             P := P + 1;
 576          end loop;
 577
 578          Skip_Eol;
 579       end Skip_Line;
 580
 581       ----------------
 582       -- Skip_Space --
 583       ----------------
 584
 585       procedure Skip_Space is
 586       begin
 587          while Nextc = ' ' or else Nextc = HT loop
 588             P := P + 1;
 589          end loop;
 590       end Skip_Space;
 591
 592       -----------
 593       -- Skipc --
 594       -----------
 595
 596       procedure Skipc is
 597       begin
 598          if P /= T'Last then
 599             P := P + 1;
 600          end if;
 601       end Skipc;
 602
 603    --  Start of processing for Scan_ALI
 604
 605    begin
 606       First_Sdep_Entry := Sdep.Last + 1;
 607
 608       --  Acquire lines to be ignored
 609
 610       if Read_Xref then
 611          Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True);
 612
 613       --  Read_Lines parameter given
 614
 615       elsif Read_Lines /= "" then
 616          Ignore := ('U' => False, others => True);
 617
 618          for J in Read_Lines'Range loop
 619             Ignore (Read_Lines (J)) := False;
 620          end loop;
 621
 622       --  Process Ignore_Lines parameter
 623
 624       else
 625          Ignore := (others => False);
 626
 627          for J in Ignore_Lines'Range loop
 628             pragma Assert (Ignore_Lines (J) /= 'U');
 629             Ignore (Ignore_Lines (J)) := True;
 630          end loop;
 631       end if;
 632
 633       --  Setup ALI Table entry with appropriate defaults
 634
 635       ALIs.Increment_Last;
 636       Id := ALIs.Last;
 637       Set_Name_Table_Info (F, Int (Id));
 638
 639       ALIs.Table (Id) := (
 640         Afile                      => F,
 641         Compile_Errors             => False,
 642         First_Interrupt_State      => Interrupt_States.Last + 1,
 643         First_Sdep                 => No_Sdep_Id,
 644         First_Unit                 => No_Unit_Id,
 645         Float_Format               => 'I',
 646         Last_Interrupt_State       => Interrupt_States.Last,
 647         Last_Sdep                  => No_Sdep_Id,
 648         Last_Unit                  => No_Unit_Id,
 649         Locking_Policy             => ' ',
 650         Main_Priority              => -1,
 651         Main_Program               => None,
 652         No_Object                  => False,
 653         Normalize_Scalars          => False,
 654         Ofile_Full_Name            => Full_Object_File_Name,
 655         Queuing_Policy             => ' ',
 656         Restrictions               => Restrictions_Initial,
 657         SAL_Interface              => False,
 658         Sfile                      => No_Name,
 659         Task_Dispatching_Policy    => ' ',
 660         Time_Slice_Value           => -1,
 661         WC_Encoding                => '8',
 662         Unit_Exception_Table       => False,
 663         Ver                        => (others => ' '),
 664         Ver_Len                    => 0,
 665         Zero_Cost_Exceptions       => False);
 666
 667       --  Now we acquire the input lines from the ALI file. Note that the
 668       --  convention in the following code is that as we enter each section,
 669       --  C is set to contain the first character of the following line.
 670
 671       C := Getc;
 672       Check_Unknown_Line;
 673
 674       --  Acquire library version
 675
 676       if C /= 'V' then
 677
 678          --  The V line missing really indicates trouble, most likely it
 679          --  means we don't have an ALI file at all, so here we give a
 680          --  fatal error even if we are in Ignore_Errors mode.
 681
 682          Fatal_Error;
 683
 684       elsif Ignore ('V') then
 685          Skip_Line;
 686
 687       else
 688          Checkc (' ');
 689          Skip_Space;
 690          Checkc ('"');
 691
 692          for J in 1 .. Ver_Len_Max loop
 693             C := Getc;
 694             exit when C = '"';
 695             ALIs.Table (Id).Ver (J) := C;
 696             ALIs.Table (Id).Ver_Len := J;
 697          end loop;
 698
 699          Skip_Eol;
 700       end if;
 701
 702       C := Getc;
 703       Check_Unknown_Line;
 704
 705       --  Acquire main program line if present
 706
 707       if C = 'M' then
 708          if Ignore ('M') then
 709             Skip_Line;
 710
 711          else
 712             Checkc (' ');
 713             Skip_Space;
 714
 715             C := Getc;
 716
 717             if C = 'F' then
 718                ALIs.Table (Id).Main_Program := Func;
 719             elsif C = 'P' then
 720                ALIs.Table (Id).Main_Program := Proc;
 721             else
 722                P := P - 1;
 723                Fatal_Error;
 724             end if;
 725
 726             Skip_Space;
 727
 728             if not At_Eol then
 729                if Nextc < 'A' then
 730                   ALIs.Table (Id).Main_Priority := Get_Nat;
 731                end if;
 732
 733                Skip_Space;
 734
 735                if Nextc = 'T' then
 736                   P := P + 1;
 737                   Checkc ('=');
 738                   ALIs.Table (Id).Time_Slice_Value := Get_Nat;
 739                end if;
 740
 741                Skip_Space;
 742
 743                Checkc ('W');
 744                Checkc ('=');
 745                ALIs.Table (Id).WC_Encoding := Getc;
 746             end if;
 747
 748             Skip_Eol;
 749          end if;
 750
 751          C := Getc;
 752       end if;
 753
 754       --  Acquire argument lines
 755
 756       First_Arg := Args.Last + 1;
 757
 758       A_Loop : loop
 759          Check_Unknown_Line;
 760          exit A_Loop when C /= 'A';
 761
 762          if Ignore ('A') then
 763             Skip_Line;
 764
 765          else
 766             Checkc (' ');
 767             Name_Len := 0;
 768
 769             while not At_Eol loop
 770                Name_Len := Name_Len + 1;
 771                Name_Buffer (Name_Len) := Getc;
 772             end loop;
 773
 774             Args.Increment_Last;
 775             Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
 776
 777             Skip_Eol;
 778          end if;
 779
 780          C := Getc;
 781       end loop A_Loop;
 782
 783       --  Acquire P line
 784
 785       Check_Unknown_Line;
 786
 787       while C /= 'P' loop
 788          if Ignore_Errors then
 789             if C = EOF then
 790                Fatal_Error;
 791             else
 792                Skip_Line;
 793                C := Nextc;
 794             end if;
 795          else
 796             Fatal_Error;
 797          end if;
 798       end loop;
 799
 800       if Ignore ('P') then
 801          Skip_Line;
 802
 803       --  Process P line
 804
 805       else
 806          NS_Found := False;
 807
 808          while not At_Eol loop
 809             Checkc (' ');
 810             Skip_Space;
 811             C := Getc;
 812
 813             --  Processing for CE
 814
 815             if C = 'C' then
 816                Checkc ('E');
 817                ALIs.Table (Id).Compile_Errors := True;
 818
 819             --  Processing for DB
 820
 821             elsif C = 'D' then
 822                Checkc ('B');
 823                Detect_Blocking := True;
 824
 825             --  Processing for FD/FG/FI
 826
 827             elsif C = 'F' then
 828                Float_Format_Specified := Getc;
 829                ALIs.Table (Id).Float_Format := Float_Format_Specified;
 830
 831             --  Processing for Lx
 832
 833             elsif C = 'L' then
 834                Locking_Policy_Specified := Getc;
 835                ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
 836
 837             --  Processing for flags starting with N
 838
 839             elsif C = 'N' then
 840                C := Getc;
 841
 842                --  Processing for NO
 843
 844                if C = 'O' then
 845                   ALIs.Table (Id).No_Object := True;
 846                   No_Object_Specified := True;
 847
 848                --  Processing for NR
 849
 850                elsif C = 'R' then
 851                   No_Run_Time_Mode           := True;
 852                   Configurable_Run_Time_Mode := True;
 853
 854                --  Processing for NS
 855
 856                elsif C = 'S' then
 857                   ALIs.Table (Id).Normalize_Scalars := True;
 858                   Normalize_Scalars_Specified := True;
 859                   NS_Found := True;
 860
 861                --  Invalid switch starting with N
 862
 863                else
 864                   Fatal_Error_Ignore;
 865                end if;
 866
 867             --  Processing for Qx
 868
 869             elsif C = 'Q' then
 870                Queuing_Policy_Specified := Getc;
 871                ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
 872
 873             --  Processing for flags starting with S
 874
 875             elsif C = 'S' then
 876                C := Getc;
 877
 878                --  Processing for SL
 879
 880                if C = 'L' then
 881                   ALIs.Table (Id).SAL_Interface := True;
 882
 883                --  Processing for SS
 884
 885                elsif C = 'S' then
 886                   Opt.Sec_Stack_Used := True;
 887
 888                --  Invalid switch starting with S
 889
 890                else
 891                   Fatal_Error_Ignore;
 892                end if;
 893
 894             --  Processing for Tx
 895
 896             elsif C = 'T' then
 897                Task_Dispatching_Policy_Specified := Getc;
 898                ALIs.Table (Id).Task_Dispatching_Policy :=
 899                  Task_Dispatching_Policy_Specified;
 900
 901             --  Processing for switch starting with U
 902
 903             elsif C = 'U' then
 904                C := Getc;
 905
 906                --  Processing for UA
 907
 908                if C  = 'A' then
 909                   Unreserve_All_Interrupts_Specified := True;
 910
 911                --  Processing for UX
 912
 913                elsif C = 'X' then
 914                   ALIs.Table (Id).Unit_Exception_Table := True;
 915
 916                --  Invalid switches starting with U
 917
 918                else
 919                   Fatal_Error_Ignore;
 920                end if;
 921
 922             --  Processing for ZX
 923
 924             elsif C = 'Z' then
 925                C := Getc;
 926
 927                if C = 'X' then
 928                   ALIs.Table (Id).Zero_Cost_Exceptions := True;
 929                   Zero_Cost_Exceptions_Specified := True;
 930                else
 931                   Fatal_Error_Ignore;
 932                end if;
 933
 934             --  Invalid parameter
 935
 936             else
 937                C := Getc;
 938                Fatal_Error_Ignore;
 939             end if;
 940          end loop;
 941
 942          if not NS_Found then
 943             No_Normalize_Scalars_Specified := True;
 944          end if;
 945
 946          Skip_Eol;
 947       end if;
 948
 949       C := Getc;
 950       Check_Unknown_Line;
 951
 952       --  Acquire first restrictions line
 953
 954       while C /= 'R' loop
 955          if Ignore_Errors then
 956             if C = EOF then
 957                Fatal_Error;
 958             else
 959                Skip_Line;
 960                C := Nextc;
 961             end if;
 962          else
 963             Fatal_Error;
 964          end if;
 965       end loop;
 966
 967       if Ignore ('R') then
 968          Skip_Line;
 969
 970       --  Process restrictions line
 971
 972       else
 973          Scan_Restrictions : declare
 974             Save_R : constant Restrictions_Info := Cumulative_Restrictions;
 975             --  Save cumulative restrictions in case we have a fatal error
 976
 977             Bad_R_Line : exception;
 978             --  Signal bad restrictions line (raised on unexpected character)
 979
 980          begin
 981             Checkc (' ');
 982             Skip_Space;
 983
 984             --  Acquire information for boolean restrictions
 985
 986             for R in All_Boolean_Restrictions loop
 987                C := Getc;
 988
 989                case C is
 990                   when 'v' =>
 991                      ALIs.Table (Id).Restrictions.Violated (R) := True;
 992                      Cumulative_Restrictions.Violated (R) := True;
 993
 994                   when 'r' =>
 995                      ALIs.Table (Id).Restrictions.Set (R) := True;
 996                      Cumulative_Restrictions.Set (R) := True;
 997
 998                   when 'n' =>
 999                      null;
1000
1001                   when others =>
1002                      raise Bad_R_Line;
1003                end case;
1004             end loop;
1005
1006             --  Acquire information for parameter restrictions
1007
1008             for RP in All_Parameter_Restrictions loop
1009
1010                --  Acquire restrictions pragma information
1011
1012                case Getc is
1013                   when 'n' =>
1014                      null;
1015
1016                   when 'r' =>
1017                      ALIs.Table (Id).Restrictions.Set (RP) := True;
1018
1019                      declare
1020                         N : constant Integer := Integer (Get_Nat);
1021                      begin
1022                         ALIs.Table (Id).Restrictions.Value (RP) := N;
1023
1024                         if Cumulative_Restrictions.Set (RP) then
1025                            Cumulative_Restrictions.Value (RP) :=
1026                              Integer'Min
1027                                (Cumulative_Restrictions.Value (RP), N);
1028                         else
1029                            Cumulative_Restrictions.Set (RP) := True;
1030                            Cumulative_Restrictions.Value (RP) := N;
1031                         end if;
1032                      end;
1033
1034                   when others =>
1035                      raise Bad_R_Line;
1036                end case;
1037
1038                --  Acquire restrictions violations information
1039
1040                case Getc is
1041                   when 'n' =>
1042                      null;
1043
1044                   when 'v' =>
1045                      ALIs.Table (Id).Restrictions.Violated (RP) := True;
1046                      Cumulative_Restrictions.Violated (RP) := True;
1047
1048                      declare
1049                         N : constant Integer := Integer (Get_Nat);
1050                         pragma Unsuppress (Overflow_Check);
1051
1052                      begin
1053                         ALIs.Table (Id).Restrictions.Count (RP) := N;
1054
1055                         if RP in Checked_Max_Parameter_Restrictions then
1056                            Cumulative_Restrictions.Count (RP) :=
1057                              Integer'Max
1058                                (Cumulative_Restrictions.Count (RP), N);
1059                         else
1060                            Cumulative_Restrictions.Count (RP) :=
1061                              Cumulative_Restrictions.Count (RP) + N;
1062                         end if;
1063
1064                      exception
1065                         when Constraint_Error =>
1066
1067                            --  A constraint error comes from the addition in
1068                            --  the else branch. We reset to the maximum and
1069                            --  indicate that the real value is now unknown.
1070
1071                            Cumulative_Restrictions.Value (RP) := Integer'Last;
1072                            Cumulative_Restrictions.Unknown (RP) := True;
1073                      end;
1074
1075                      if Nextc = '+' then
1076                         Skipc;
1077                         ALIs.Table (Id).Restrictions.Unknown (RP) := True;
1078                         Cumulative_Restrictions.Unknown (RP) := True;
1079                      end if;
1080
1081                   when others =>
1082                      raise Bad_R_Line;
1083                end case;
1084             end loop;
1085
1086             Skip_Eol;
1087
1088          --  Here if error during scanning of restrictions line
1089
1090          exception
1091             when Bad_R_Line =>
1092
1093                --  In Ignore_Errors mode, undo any changes to restrictions
1094                --  from this unit, and continue on.
1095
1096                if Ignore_Errors then
1097                   Cumulative_Restrictions := Save_R;
1098                   ALIs.Table (Id).Restrictions := Restrictions_Initial;
1099                   Skip_Eol;
1100
1101                --  In normal mode, this is a fatal error
1102
1103                else
1104                   Fatal_Error;
1105                end if;
1106
1107          end Scan_Restrictions;
1108       end if;
1109
1110       --  Acquire additional restrictions (No_Dependence) lines if present
1111
1112       C := Getc;
1113       while C = 'R' loop
1114          if Ignore ('R') then
1115             Skip_Line;
1116          else
1117             Skip_Space;
1118             No_Deps.Append ((Id, Get_Name));
1119          end if;
1120
1121          Skip_Eol;
1122          C := Getc;
1123       end loop;
1124
1125       --  Acquire 'I' lines if present
1126
1127       Check_Unknown_Line;
1128
1129       while C = 'I' loop
1130          if Ignore ('I') then
1131             Skip_Line;
1132
1133          else
1134             declare
1135                Int_Num : Nat;
1136                I_State : Character;
1137                Line_No : Nat;
1138
1139             begin
1140                Int_Num := Get_Nat;
1141                Skip_Space;
1142                I_State := Getc;
1143                Line_No := Get_Nat;
1144
1145                Interrupt_States.Append (
1146                  (Interrupt_Id    => Int_Num,
1147                   Interrupt_State => I_State,
1148                   IS_Pragma_Line  => Line_No));
1149
1150                ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
1151                Skip_Eol;
1152             end;
1153          end if;
1154
1155          C := Getc;
1156       end loop;
1157
1158       --  Loop to acquire unit entries
1159
1160       U_Loop : loop
1161          Check_Unknown_Line;
1162          exit U_Loop when C /= 'U';
1163
1164          --  Note: as per spec, we never ignore U lines
1165
1166          Checkc (' ');
1167          Skip_Space;
1168          Units.Increment_Last;
1169
1170          if ALIs.Table (Id).First_Unit = No_Unit_Id then
1171             ALIs.Table (Id).First_Unit := Units.Last;
1172          end if;
1173
1174          Units.Table (Units.Last).Uname           := Get_Name;
1175          Units.Table (Units.Last).Predefined      := Is_Predefined_Unit;
1176          Units.Table (Units.Last).Internal        := Is_Internal_Unit;
1177          Units.Table (Units.Last).My_ALI          := Id;
1178          Units.Table (Units.Last).Sfile           := Get_Name (Lower => True);
1179          Units.Table (Units.Last).Pure            := False;
1180          Units.Table (Units.Last).Preelab         := False;
1181          Units.Table (Units.Last).No_Elab         := False;
1182          Units.Table (Units.Last).Shared_Passive  := False;
1183          Units.Table (Units.Last).RCI             := False;
1184          Units.Table (Units.Last).Remote_Types    := False;
1185          Units.Table (Units.Last).Has_RACW        := False;
1186          Units.Table (Units.Last).Init_Scalars    := False;
1187          Units.Table (Units.Last).Is_Generic      := False;
1188          Units.Table (Units.Last).Icasing         := Mixed_Case;
1189          Units.Table (Units.Last).Kcasing         := All_Lower_Case;
1190          Units.Table (Units.Last).Dynamic_Elab    := False;
1191          Units.Table (Units.Last).Elaborate_Body  := False;
1192          Units.Table (Units.Last).Set_Elab_Entity := False;
1193          Units.Table (Units.Last).Version         := "00000000";
1194          Units.Table (Units.Last).First_With      := Withs.Last + 1;
1195          Units.Table (Units.Last).First_Arg       := First_Arg;
1196          Units.Table (Units.Last).Elab_Position   := 0;
1197          Units.Table (Units.Last).SAL_Interface   := ALIs.Table (Id).
1198                                                        SAL_Interface;
1199          Units.Table (Units.Last).Body_Needed_For_SAL := False;
1200
1201          if Debug_Flag_U then
1202             Write_Str (" ----> reading unit ");
1203             Write_Int (Int (Units.Last));
1204             Write_Str ("  ");
1205             Write_Unit_Name (Units.Table (Units.Last).Uname);
1206             Write_Str (" from file ");
1207             Write_Name (Units.Table (Units.Last).Sfile);
1208             Write_Eol;
1209          end if;
1210
1211          --  Check for duplicated unit in different files
1212
1213          declare
1214             Info : constant Int := Get_Name_Table_Info
1215                                      (Units.Table (Units.Last).Uname);
1216          begin
1217             if Info /= 0
1218               and then Units.Table (Units.Last).Sfile /=
1219                        Units.Table (Unit_Id (Info)).Sfile
1220             then
1221                --  If Err is set then ignore duplicate unit name. This is the
1222                --  case of a call from gnatmake, where the situation can arise
1223                --  from substitution of source files. In such situations, the
1224                --  processing in gnatmake will always result in any required
1225                --  recompilations in any case, and if we consider this to be
1226                --  an error we get strange cases (for example when a generic
1227                --  instantiation is replaced by a normal package) where we
1228                --  read the old ali file, decide to recompile, and then decide
1229                --  that the old and new ali files are incompatible.
1230
1231                if Err then
1232                   null;
1233
1234                --  If Err is not set, then this is a fatal error. This is
1235                --  the case of being called from the binder, where we must
1236                --  definitely diagnose this as an error.
1237
1238                else
1239                   Set_Standard_Error;
1240                   Write_Str ("error: duplicate unit name: ");
1241                   Write_Eol;
1242
1243                   Write_Str ("error: unit """);
1244                   Write_Unit_Name (Units.Table (Units.Last).Uname);
1245                   Write_Str (""" found in file """);
1246                   Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1247                   Write_Char ('"');
1248                   Write_Eol;
1249
1250                   Write_Str ("error: unit """);
1251                   Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1252                   Write_Str (""" found in file """);
1253                   Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1254                   Write_Char ('"');
1255                   Write_Eol;
1256
1257                   Exit_Program (E_Fatal);
1258                end if;
1259             end if;
1260          end;
1261
1262          Set_Name_Table_Info
1263            (Units.Table (Units.Last).Uname, Int (Units.Last));
1264
1265          --  Scan out possible version and other parameters
1266
1267          loop
1268             Skip_Space;
1269             exit when At_Eol;
1270             C := Getc;
1271
1272             --  Version field
1273
1274             if C in '0' .. '9' or else C in 'a' .. 'f' then
1275                Units.Table (Units.Last).Version (1) := C;
1276
1277                for J in 2 .. 8 loop
1278                   C := Getc;
1279                   Units.Table (Units.Last).Version (J) := C;
1280                end loop;
1281
1282             --  BN parameter (Body needed)
1283
1284             elsif C = 'B' then
1285                C := Getc;
1286
1287                if C = 'N' then
1288                   Check_At_End_Of_Field;
1289                   Units.Table (Units.Last).Body_Needed_For_SAL := True;
1290                else
1291                   Fatal_Error_Ignore;
1292                end if;
1293
1294             --  DE parameter (Dynamic elaboration checks)
1295
1296             elsif C = 'D' then
1297                C := Getc;
1298
1299                if C = 'E' then
1300                   Check_At_End_Of_Field;
1301                   Units.Table (Units.Last).Dynamic_Elab := True;
1302                   Dynamic_Elaboration_Checks_Specified := True;
1303                else
1304                   Fatal_Error_Ignore;
1305                end if;
1306
1307             --  EB/EE parameters
1308
1309             elsif C = 'E' then
1310                C := Getc;
1311
1312                if C = 'B' then
1313                   Units.Table (Units.Last).Elaborate_Body := True;
1314                elsif C = 'E' then
1315                   Units.Table (Units.Last).Set_Elab_Entity := True;
1316                else
1317                   Fatal_Error_Ignore;
1318                end if;
1319
1320                Check_At_End_Of_Field;
1321
1322             --  GE parameter (generic)
1323
1324             elsif C = 'G' then
1325                C := Getc;
1326
1327                if C = 'E' then
1328                   Check_At_End_Of_Field;
1329                   Units.Table (Units.Last).Is_Generic := True;
1330                else
1331                   Fatal_Error_Ignore;
1332                end if;
1333
1334             --  IL/IS/IU parameters
1335
1336             elsif C = 'I' then
1337                C := Getc;
1338
1339                if C = 'L' then
1340                   Units.Table (Units.Last).Icasing := All_Lower_Case;
1341                elsif C = 'S' then
1342                   Units.Table (Units.Last).Init_Scalars := True;
1343                   Initialize_Scalars_Used := True;
1344                elsif C = 'U' then
1345                   Units.Table (Units.Last).Icasing := All_Upper_Case;
1346                else
1347                   Fatal_Error_Ignore;
1348                end if;
1349
1350                Check_At_End_Of_Field;
1351
1352             --  KM/KU parameters
1353
1354             elsif C = 'K' then
1355                C := Getc;
1356
1357                if C = 'M' then
1358                   Units.Table (Units.Last).Kcasing := Mixed_Case;
1359                elsif C = 'U' then
1360                   Units.Table (Units.Last).Kcasing := All_Upper_Case;
1361                else
1362                   Fatal_Error_Ignore;
1363                end if;
1364
1365                Check_At_End_Of_Field;
1366
1367             --  NE parameter
1368
1369             elsif C = 'N' then
1370                C := Getc;
1371
1372                if C = 'E' then
1373                   Units.Table (Units.Last).No_Elab := True;
1374                   Check_At_End_Of_Field;
1375                else
1376                   Fatal_Error_Ignore;
1377                end if;
1378
1379             --  PR/PU/PK parameters
1380
1381             elsif C = 'P' then
1382                C := Getc;
1383
1384                if C = 'R' then
1385                   Units.Table (Units.Last).Preelab := True;
1386                elsif C = 'U' then
1387                   Units.Table (Units.Last).Pure := True;
1388                elsif C = 'K' then
1389                   Units.Table (Units.Last).Unit_Kind := 'p';
1390                else
1391                   Fatal_Error_Ignore;
1392                end if;
1393
1394                Check_At_End_Of_Field;
1395
1396             --  RC/RT parameters
1397
1398             elsif C = 'R' then
1399                C := Getc;
1400
1401                if C = 'C' then
1402                   Units.Table (Units.Last).RCI := True;
1403                elsif C = 'T' then
1404                   Units.Table (Units.Last).Remote_Types := True;
1405                elsif C = 'A' then
1406                   Units.Table (Units.Last).Has_RACW := True;
1407                else
1408                   Fatal_Error_Ignore;
1409                end if;
1410
1411                Check_At_End_Of_Field;
1412
1413             elsif C = 'S' then
1414                C := Getc;
1415
1416                if C = 'P' then
1417                   Units.Table (Units.Last).Shared_Passive := True;
1418                elsif C = 'U' then
1419                   Units.Table (Units.Last).Unit_Kind := 's';
1420                else
1421                   Fatal_Error_Ignore;
1422                end if;
1423
1424                Check_At_End_Of_Field;
1425
1426             else
1427                C := Getc;
1428                Fatal_Error_Ignore;
1429             end if;
1430          end loop;
1431
1432          Skip_Eol;
1433
1434          --  Check if static elaboration model used
1435
1436          if not Units.Table (Units.Last).Dynamic_Elab
1437            and then not Units.Table (Units.Last).Internal
1438          then
1439             Static_Elaboration_Model_Used := True;
1440          end if;
1441
1442          C := Getc;
1443
1444          --  Scan out With lines for this unit
1445
1446          With_Loop : loop
1447             Check_Unknown_Line;
1448             exit With_Loop when C /= 'W';
1449
1450             if Ignore ('W') then
1451                Skip_Line;
1452
1453             else
1454                Checkc (' ');
1455                Skip_Space;
1456                Withs.Increment_Last;
1457                Withs.Table (Withs.Last).Uname              := Get_Name;
1458                Withs.Table (Withs.Last).Elaborate          := False;
1459                Withs.Table (Withs.Last).Elaborate_All      := False;
1460                Withs.Table (Withs.Last).Elab_All_Desirable := False;
1461                Withs.Table (Withs.Last).SAL_Interface      := False;
1462
1463                --  Generic case with no object file available
1464
1465                if At_Eol then
1466                   Withs.Table (Withs.Last).Sfile := No_File;
1467                   Withs.Table (Withs.Last).Afile := No_File;
1468
1469                --  Normal case
1470
1471                else
1472                   Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
1473                   Withs.Table (Withs.Last).Afile := Get_Name;
1474
1475                   --  Scan out possible E, EA, and NE parameters
1476
1477                   while not At_Eol loop
1478                      Skip_Space;
1479
1480                      if Nextc = 'E' then
1481                         P := P + 1;
1482
1483                         if At_End_Of_Field then
1484                            Withs.Table (Withs.Last).Elaborate := True;
1485
1486                         elsif Nextc = 'A' then
1487                            P := P + 1;
1488                            Check_At_End_Of_Field;
1489                            Withs.Table (Withs.Last).Elaborate_All := True;
1490
1491                         else
1492                            Checkc ('D');
1493                            Check_At_End_Of_Field;
1494
1495                            --  Store ED indication unless ignore required
1496
1497                            if not Ignore_ED then
1498                               Withs.Table (Withs.Last).Elab_All_Desirable :=
1499                                 True;
1500                            end if;
1501                         end if;
1502                      end if;
1503                   end loop;
1504                end if;
1505
1506                Skip_Eol;
1507             end if;
1508
1509             C := Getc;
1510          end loop With_Loop;
1511
1512          Units.Table (Units.Last).Last_With := Withs.Last;
1513          Units.Table (Units.Last).Last_Arg  := Args.Last;
1514
1515          --  If there are linker options lines present, scan them
1516
1517          Name_Len := 0;
1518
1519          Linker_Options_Loop : loop
1520             Check_Unknown_Line;
1521             exit Linker_Options_Loop when C /= 'L';
1522
1523             if Ignore ('L') then
1524                Skip_Line;
1525
1526             else
1527                Checkc (' ');
1528                Skip_Space;
1529                Checkc ('"');
1530
1531                loop
1532                   C := Getc;
1533
1534                   if C < Character'Val (16#20#)
1535                     or else C > Character'Val (16#7E#)
1536                   then
1537                      Fatal_Error_Ignore;
1538
1539                   elsif C = '{' then
1540                      C := Character'Val (0);
1541
1542                      declare
1543                         V : Natural;
1544
1545                      begin
1546                         V := 0;
1547                         for J in 1 .. 2 loop
1548                            C := Getc;
1549
1550                            if C in '0' .. '9' then
1551                               V := V * 16 +
1552                                      Character'Pos (C) -
1553                                        Character'Pos ('0');
1554
1555                            elsif C in 'A' .. 'F' then
1556                               V := V * 16 +
1557                                      Character'Pos (C) -
1558                                        Character'Pos ('A') +
1559                                          10;
1560
1561                            else
1562                               Fatal_Error_Ignore;
1563                            end if;
1564                         end loop;
1565
1566                         Checkc ('}');
1567                         Add_Char_To_Name_Buffer (Character'Val (V));
1568                      end;
1569
1570                   else
1571                      if C = '"' then
1572                         exit when Nextc /= '"';
1573                         C := Getc;
1574                      end if;
1575
1576                      Add_Char_To_Name_Buffer (C);
1577                   end if;
1578                end loop;
1579
1580                Add_Char_To_Name_Buffer (nul);
1581                Skip_Eol;
1582             end if;
1583
1584             C := Getc;
1585          end loop Linker_Options_Loop;
1586
1587          --  Store the linker options entry if one was found
1588
1589          if Name_Len /= 0 then
1590             Linker_Options.Increment_Last;
1591
1592             Linker_Options.Table (Linker_Options.Last).Name :=
1593               Name_Enter;
1594
1595             Linker_Options.Table (Linker_Options.Last).Unit :=
1596               Units.Last;
1597
1598             Linker_Options.Table (Linker_Options.Last).Internal_File :=
1599               Is_Internal_File_Name (F);
1600
1601             Linker_Options.Table (Linker_Options.Last).Original_Pos :=
1602               Linker_Options.Last;
1603          end if;
1604       end loop U_Loop;
1605
1606       --  End loop through units for one ALI file
1607
1608       ALIs.Table (Id).Last_Unit := Units.Last;
1609       ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
1610
1611       --  Set types of the units (there can be at most 2 of them)
1612
1613       if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
1614          Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
1615          Units.Table (ALIs.Table (Id).Last_Unit).Utype  := Is_Spec;
1616
1617       else
1618          --  Deal with body only and spec only cases, note that the reason we
1619          --  do our own checking of the name (rather than using Is_Body_Name)
1620          --  is that Uname drags in far too much compiler junk!
1621
1622          Get_Name_String (Units.Table (Units.Last).Uname);
1623
1624          if Name_Buffer (Name_Len) = 'b' then
1625             Units.Table (Units.Last).Utype := Is_Body_Only;
1626          else
1627             Units.Table (Units.Last).Utype := Is_Spec_Only;
1628          end if;
1629       end if;
1630
1631       --  Scan out external version references and put in hash table
1632
1633       E_Loop : loop
1634          Check_Unknown_Line;
1635          exit E_Loop when C /= 'E';
1636
1637          if Ignore ('E') then
1638             Skip_Line;
1639
1640          else
1641             Checkc (' ');
1642             Skip_Space;
1643
1644             Name_Len := 0;
1645             Name_Len := 0;
1646             loop
1647                C := Getc;
1648
1649                if C < ' ' then
1650                   Fatal_Error;
1651                end if;
1652
1653                exit when At_End_Of_Field;
1654                Add_Char_To_Name_Buffer (C);
1655             end loop;
1656
1657             Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
1658             Skip_Eol;
1659          end if;
1660
1661          C := Getc;
1662       end loop E_Loop;
1663
1664       --  Scan out source dependency lines for this ALI file
1665
1666       ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
1667
1668       D_Loop : loop
1669          Check_Unknown_Line;
1670          exit D_Loop when C /= 'D';
1671
1672          if Ignore ('D') then
1673             Skip_Line;
1674
1675          else
1676             Checkc (' ');
1677             Skip_Space;
1678             Sdep.Increment_Last;
1679             Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
1680             Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
1681             Sdep.Table (Sdep.Last).Dummy_Entry :=
1682               (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
1683
1684             --  Acquire checksum value
1685
1686             Skip_Space;
1687
1688             declare
1689                Ctr : Natural;
1690                Chk : Word;
1691
1692             begin
1693                Ctr := 0;
1694                Chk := 0;
1695
1696                loop
1697                   exit when At_Eol or else Ctr = 8;
1698
1699                   if Nextc in '0' .. '9' then
1700                      Chk := Chk * 16 +
1701                               Character'Pos (Nextc) - Character'Pos ('0');
1702
1703                   elsif Nextc in 'a' .. 'f' then
1704                      Chk := Chk * 16 +
1705                               Character'Pos (Nextc) - Character'Pos ('a') + 10;
1706
1707                   else
1708                      exit;
1709                   end if;
1710
1711                   Ctr := Ctr + 1;
1712                   P := P + 1;
1713                end loop;
1714
1715                if Ctr = 8 and then At_End_Of_Field then
1716                   Sdep.Table (Sdep.Last).Checksum := Chk;
1717                else
1718                   Fatal_Error;
1719                end if;
1720             end;
1721
1722             --  Acquire subunit and reference file name entries
1723
1724             Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
1725             Sdep.Table (Sdep.Last).Rfile        :=
1726               Sdep.Table (Sdep.Last).Sfile;
1727             Sdep.Table (Sdep.Last).Start_Line   := 1;
1728
1729             if not At_Eol then
1730                Skip_Space;
1731
1732                --  Here for subunit name
1733
1734                if Nextc not in '0' .. '9' then
1735                   Name_Len := 0;
1736
1737                   while not At_End_Of_Field loop
1738                      Name_Len := Name_Len + 1;
1739                      Name_Buffer (Name_Len) := Getc;
1740                   end loop;
1741
1742                   Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
1743                   Skip_Space;
1744                end if;
1745
1746                --  Here for reference file name entry
1747
1748                if Nextc in '0' .. '9' then
1749                   Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
1750                   Checkc (':');
1751
1752                   Name_Len := 0;
1753
1754                   while not At_End_Of_Field loop
1755                      Name_Len := Name_Len + 1;
1756                      Name_Buffer (Name_Len) := Getc;
1757                   end loop;
1758
1759                   Sdep.Table (Sdep.Last).Rfile := Name_Enter;
1760                end if;
1761             end if;
1762
1763             Skip_Eol;
1764          end if;
1765
1766          C := Getc;
1767       end loop D_Loop;
1768
1769       ALIs.Table (Id).Last_Sdep := Sdep.Last;
1770
1771       --  We must at this stage be at an Xref line or the end of file
1772
1773       if C = EOF then
1774          return Id;
1775       end if;
1776
1777       Check_Unknown_Line;
1778
1779       if C /= 'X' then
1780          Fatal_Error;
1781       end if;
1782
1783       --  If we are ignoring Xref sections we are done (we ignore all
1784       --  remaining lines since only xref related lines follow X).
1785
1786       if Ignore ('X') and then not Debug_Flag_X then
1787          return Id;
1788       end if;
1789
1790       --  Loop through Xref sections
1791
1792       X_Loop : loop
1793          Check_Unknown_Line;
1794          exit X_Loop when C /= 'X';
1795
1796          --  Make new entry in section table
1797
1798          Xref_Section.Increment_Last;
1799
1800          Read_Refs_For_One_File : declare
1801             XS : Xref_Section_Record renames
1802                    Xref_Section.Table (Xref_Section.Last);
1803
1804             Current_File_Num : Sdep_Id;
1805             --  Keeps track of the current file number (changed by nn|)
1806
1807          begin
1808             XS.File_Num     := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
1809             XS.File_Name    := Get_Name;
1810             XS.First_Entity := Xref_Entity.Last + 1;
1811
1812             Current_File_Num := XS.File_Num;
1813
1814             Skip_Space;
1815
1816             Skip_Eol;
1817             C := Nextc;
1818
1819             --  Loop through Xref entities
1820
1821             while C /= 'X' and then C /= EOF loop
1822                Xref_Entity.Increment_Last;
1823
1824                Read_Refs_For_One_Entity : declare
1825                   XE : Xref_Entity_Record renames
1826                          Xref_Entity.Table (Xref_Entity.Last);
1827                   N  : Nat;
1828
1829                   procedure Read_Instantiation_Reference;
1830                   --  Acquire instantiation reference. Caller has checked
1831                   --  that current character is '[' and on return the cursor
1832                   --  is skipped past the corresponding closing ']'.
1833
1834                   ----------------------------------
1835                   -- Read_Instantiation_Reference --
1836                   ----------------------------------
1837
1838                   procedure Read_Instantiation_Reference is
1839                      Local_File_Num : Sdep_Id := Current_File_Num;
1840
1841                   begin
1842                      Xref.Increment_Last;
1843
1844                      declare
1845                         XR : Xref_Record renames Xref.Table (Xref.Last);
1846
1847                      begin
1848                         P := P + 1; -- skip [
1849                         N := Get_Nat;
1850
1851                         if Nextc = '|' then
1852                            XR.File_Num :=
1853                              Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1854                            Local_File_Num := XR.File_Num;
1855                            P := P + 1;
1856                            N := Get_Nat;
1857
1858                         else
1859                            XR.File_Num := Local_File_Num;
1860                         end if;
1861
1862                         XR.Line  := N;
1863                         XR.Rtype := ' ';
1864                         XR.Col   := 0;
1865
1866                         --  Recursive call for next reference
1867
1868                         if Nextc = '[' then
1869                            pragma Warnings (Off); -- kill recursion warning
1870                            Read_Instantiation_Reference;
1871                            pragma Warnings (On);
1872                         end if;
1873
1874                         --  Skip closing bracket after recursive call
1875
1876                         P := P + 1;
1877                      end;
1878                   end Read_Instantiation_Reference;
1879
1880                --  Start of processing for Read_Refs_For_One_Entity
1881
1882                begin
1883                   XE.Line   := Get_Nat;
1884                   XE.Etype  := Getc;
1885                   XE.Col    := Get_Nat;
1886                   XE.Lib    := (Getc = '*');
1887                   XE.Entity := Get_Name;
1888
1889                   Current_File_Num := XS.File_Num;
1890
1891                   --  Renaming reference is present
1892
1893                   if Nextc = '=' then
1894                      P := P + 1;
1895                      XE.Rref_Line := Get_Nat;
1896
1897                      if Getc /= ':' then
1898                         Fatal_Error;
1899                      end if;
1900
1901                      XE.Rref_Col := Get_Nat;
1902
1903                   --  No renaming reference present
1904
1905                   else
1906                      XE.Rref_Line := 0;
1907                      XE.Rref_Col  := 0;
1908                   end if;
1909
1910                   Skip_Space;
1911
1912                   --  See if type reference present
1913
1914                   case Nextc is
1915                      when '<'    => XE.Tref := Tref_Derived;
1916                      when '('    => XE.Tref := Tref_Access;
1917                      when '{'    => XE.Tref := Tref_Type;
1918                      when others => XE.Tref := Tref_None;
1919                   end case;
1920
1921                   --  Case of typeref field present
1922
1923                   if XE.Tref /= Tref_None then
1924                      P := P + 1; -- skip opening bracket
1925
1926                      if Nextc in 'a' .. 'z' then
1927                         XE.Tref_File_Num        := No_Sdep_Id;
1928                         XE.Tref_Line            := 0;
1929                         XE.Tref_Type            := ' ';
1930                         XE.Tref_Col             := 0;
1931                         XE.Tref_Standard_Entity :=
1932                           Get_Name (Ignore_Spaces => True);
1933
1934                      else
1935                         N := Get_Nat;
1936
1937                         if Nextc = '|' then
1938                            XE.Tref_File_Num :=
1939                              Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1940                            P := P + 1;
1941                            N := Get_Nat;
1942
1943                         else
1944                            XE.Tref_File_Num := Current_File_Num;
1945                         end if;
1946
1947                         XE.Tref_Line            := N;
1948                         XE.Tref_Type            := Getc;
1949                         XE.Tref_Col             := Get_Nat;
1950                         XE.Tref_Standard_Entity := No_Name;
1951                      end if;
1952
1953                      --  ??? Temporary workaround for nested generics case:
1954                      --     4i4 Directories{1|4I9[4|6[3|3]]}
1955                      --  See C918-002
1956
1957                      declare
1958                         Nested_Brackets : Natural := 0;
1959
1960                      begin
1961                         loop
1962                            case Nextc is
1963                               when '['   =>
1964                                  Nested_Brackets := Nested_Brackets + 1;
1965                               when ']' =>
1966                                  Nested_Brackets := Nested_Brackets - 1;
1967                               when others =>
1968                                  if Nested_Brackets = 0 then
1969                                     exit;
1970                                  end if;
1971                            end case;
1972
1973                            Skipc;
1974                         end loop;
1975                      end;
1976
1977                      P := P + 1; -- skip closing bracket
1978                      Skip_Space;
1979
1980                   --  No typeref entry present
1981
1982                   else
1983                      XE.Tref_File_Num        := No_Sdep_Id;
1984                      XE.Tref_Line            := 0;
1985                      XE.Tref_Type            := ' ';
1986                      XE.Tref_Col             := 0;
1987                      XE.Tref_Standard_Entity := No_Name;
1988                   end if;
1989
1990                   XE.First_Xref := Xref.Last + 1;
1991
1992                   --  Loop through cross-references for this entity
1993
1994                   loop
1995                      Skip_Space;
1996
1997                      if At_Eol then
1998                         Skip_Eol;
1999                         exit when Nextc /= '.';
2000                         P := P + 1;
2001                      end if;
2002
2003                      Xref.Increment_Last;
2004
2005                      declare
2006                         XR : Xref_Record renames Xref.Table (Xref.Last);
2007
2008                      begin
2009                         N := Get_Nat;
2010
2011                         if Nextc = '|' then
2012                            XR.File_Num :=
2013                              Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2014                            Current_File_Num := XR.File_Num;
2015                            P := P + 1;
2016                            N := Get_Nat;
2017                         else
2018                            XR.File_Num := Current_File_Num;
2019                         end if;
2020
2021                         XR.Line  := N;
2022                         XR.Rtype := Getc;
2023
2024                         --  Imported entities reference as in:
2025                         --    494b<c,__gnat_copy_attribs>25
2026                         --  ??? Simply skipped for now
2027
2028                         if Nextc = '<' then
2029                            while Getc /= '>' loop
2030                               null;
2031                            end loop;
2032                         end if;
2033
2034                         XR.Col   := Get_Nat;
2035
2036                         if Nextc = '[' then
2037                            Read_Instantiation_Reference;
2038                         end if;
2039                      end;
2040                   end loop;
2041
2042                   --  Record last cross-reference
2043
2044                   XE.Last_Xref := Xref.Last;
2045                   C := Nextc;
2046                end Read_Refs_For_One_Entity;
2047             end loop;
2048
2049             --  Record last entity
2050
2051             XS.Last_Entity := Xref_Entity.Last;
2052
2053          end Read_Refs_For_One_File;
2054
2055          C := Getc;
2056       end loop X_Loop;
2057
2058       --  Here after dealing with xref sections
2059
2060       if C /= EOF and then C /= 'X' then
2061          Fatal_Error;
2062       end if;
2063
2064       return Id;
2065
2066    exception
2067       when Bad_ALI_Format =>
2068          return No_ALI_Id;
2069
2070    end Scan_ALI;
2071
2072    ---------
2073    -- SEq --
2074    ---------
2075
2076    function SEq (F1, F2 : String_Ptr) return Boolean is
2077    begin
2078       return F1.all = F2.all;
2079    end SEq;
2080
2081    -----------
2082    -- SHash --
2083    -----------
2084
2085    function SHash (S : String_Ptr) return Vindex is
2086       H : Word;
2087
2088    begin
2089       H := 0;
2090       for J in S.all'Range loop
2091          H := H * 2 + Character'Pos (S (J));
2092       end loop;
2093
2094       return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
2095    end SHash;
2096
2097 end ALI;