| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- A L I -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision$ |
| -- -- |
| -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Butil; use Butil; |
| with Debug; use Debug; |
| with Fname; use Fname; |
| with Namet; use Namet; |
| with Osint; use Osint; |
| with Output; use Output; |
| |
| package body ALI is |
| |
| use ASCII; |
| -- Make control characters visible |
| |
| -------------------- |
| -- Initialize_ALI -- |
| -------------------- |
| |
| procedure Initialize_ALI is |
| begin |
| -- When (re)initializing ALI data structures the ALI user expects to |
| -- get a fresh set of data structures. Thus we first need to erase the |
| -- marks put in the name table by the previous set of ALI routine calls. |
| -- This loop is empty and harmless the first time in. |
| |
| for J in ALIs.First .. ALIs.Last loop |
| Set_Name_Table_Info (ALIs.Table (J).Afile, 0); |
| end loop; |
| |
| ALIs.Init; |
| Units.Init; |
| Withs.Init; |
| Sdep.Init; |
| Linker_Options.Init; |
| Xref_Section.Init; |
| Xref_Entity.Init; |
| Xref.Init; |
| Version_Ref.Reset; |
| |
| -- Add dummy zero'th item in Linker_Options for the sort function |
| |
| Linker_Options.Increment_Last; |
| |
| -- Initialize global variables recording cumulative options in all |
| -- ALI files that are read for a given processing run in gnatbind. |
| |
| Dynamic_Elaboration_Checks_Specified := False; |
| Float_Format_Specified := ' '; |
| Locking_Policy_Specified := ' '; |
| No_Normalize_Scalars_Specified := False; |
| No_Object_Specified := False; |
| Normalize_Scalars_Specified := False; |
| No_Run_Time_Specified := False; |
| Queuing_Policy_Specified := ' '; |
| Static_Elaboration_Model_Used := False; |
| Task_Dispatching_Policy_Specified := ' '; |
| Unreserve_All_Interrupts_Specified := False; |
| Zero_Cost_Exceptions_Specified := False; |
| |
| end Initialize_ALI; |
| |
| -------------- |
| -- Scan_ALI -- |
| -------------- |
| |
| function Scan_ALI |
| (F : File_Name_Type; |
| T : Text_Buffer_Ptr; |
| Ignore_ED : Boolean; |
| Err : Boolean; |
| Read_Xref : Boolean := False) |
| return ALI_Id |
| is |
| P : Text_Ptr := T'First; |
| Line : Logical_Line_Number := 1; |
| Id : ALI_Id; |
| C : Character; |
| NS_Found : Boolean; |
| First_Arg : Arg_Id; |
| |
| function At_Eol return Boolean; |
| -- Test if at end of line |
| |
| function At_End_Of_Field return Boolean; |
| -- Test if at end of line, or if at blank or horizontal tab |
| |
| procedure Check_At_End_Of_Field; |
| -- Check if we are at end of field, fatal error if not |
| |
| procedure Checkc (C : Character); |
| -- Check next character is C. If so bump past it, if not fatal error |
| |
| Bad_ALI_Format : exception; |
| |
| procedure Fatal_Error; |
| -- Generate fatal error message for badly formatted ALI file if |
| -- Err is false, or raise Bad_ALI_Format if Err is True. |
| |
| function Getc return Character; |
| -- Get next character, bumping P past the character obtained |
| |
| function Get_Name (Lower : Boolean := False) return Name_Id; |
| -- Skip blanks, then scan out a name (name is left in Name_Buffer with |
| -- length in Name_Len, as well as being returned in Name_Id form). The |
| -- name is adjusted appropriately if it refers to a file that is to be |
| -- substituted by another name as a result of a configuration pragma. |
| -- If Lower is set to true then the Name_Buffer will be converted to |
| -- all lower case. This only happends for systems where file names are |
| -- not case sensitive, and ensures that gnatbind works correctly on |
| -- such systems, regardless of the case of the file name. Note that |
| -- a name can be terminated by a right typeref bracket or '='. |
| |
| function Get_Nat return Nat; |
| -- Skip blanks, then scan out an unsigned integer value in Nat range |
| |
| function Get_Stamp return Time_Stamp_Type; |
| -- Skip blanks, then scan out a time stamp |
| |
| function Nextc return Character; |
| -- Return current character without modifying pointer P |
| |
| procedure Skip_Eol; |
| -- Skip past end of line (fatal error if not at end of line) |
| |
| procedure Skip_Space; |
| -- Skip past white space (blanks or horizontal tab) |
| |
| --------------------- |
| -- At_End_Of_Field -- |
| --------------------- |
| |
| function At_End_Of_Field return Boolean is |
| begin |
| return Nextc <= ' '; |
| end At_End_Of_Field; |
| |
| ------------ |
| -- At_Eol -- |
| ------------ |
| |
| function At_Eol return Boolean is |
| begin |
| return Nextc = EOF or else Nextc = CR or else Nextc = LF; |
| end At_Eol; |
| |
| --------------------------- |
| -- Check_At_End_Of_Field -- |
| --------------------------- |
| |
| procedure Check_At_End_Of_Field is |
| begin |
| if not At_End_Of_Field then |
| Fatal_Error; |
| end if; |
| end Check_At_End_Of_Field; |
| |
| ------------ |
| -- Checkc -- |
| ------------ |
| |
| procedure Checkc (C : Character) is |
| begin |
| if Nextc = C then |
| P := P + 1; |
| else |
| Fatal_Error; |
| end if; |
| end Checkc; |
| |
| ----------------- |
| -- Fatal_Error -- |
| ----------------- |
| |
| procedure Fatal_Error is |
| Ptr1 : Text_Ptr; |
| Ptr2 : Text_Ptr; |
| Col : Int; |
| |
| procedure Wchar (C : Character); |
| -- Write a single character, replacing horizontal tab by spaces |
| |
| procedure Wchar (C : Character) is |
| begin |
| if C = HT then |
| loop |
| Wchar (' '); |
| exit when Col mod 8 = 0; |
| end loop; |
| |
| else |
| Write_Char (C); |
| Col := Col + 1; |
| end if; |
| end Wchar; |
| |
| -- Start of processing for Fatal_Error |
| |
| begin |
| if Err then |
| raise Bad_ALI_Format; |
| end if; |
| |
| Set_Standard_Error; |
| Write_Str ("fatal error: file "); |
| Write_Name (F); |
| Write_Str (" is incorrectly formatted"); |
| Write_Eol; |
| Write_Str |
| ("make sure you are using consistent versions of gcc/gnatbind"); |
| Write_Eol; |
| |
| -- Find start of line |
| |
| Ptr1 := P; |
| |
| while Ptr1 > T'First |
| and then T (Ptr1 - 1) /= CR |
| and then T (Ptr1 - 1) /= LF |
| loop |
| Ptr1 := Ptr1 - 1; |
| end loop; |
| |
| Write_Int (Int (Line)); |
| Write_Str (". "); |
| |
| if Line < 100 then |
| Write_Char (' '); |
| end if; |
| |
| if Line < 10 then |
| Write_Char (' '); |
| end if; |
| |
| Col := 0; |
| Ptr2 := Ptr1; |
| |
| while Ptr2 < T'Last |
| and then T (Ptr2) /= CR |
| and then T (Ptr2) /= LF |
| loop |
| Wchar (T (Ptr2)); |
| Ptr2 := Ptr2 + 1; |
| end loop; |
| |
| Write_Eol; |
| |
| Write_Str (" "); |
| Col := 0; |
| |
| while Ptr1 < P loop |
| if T (Ptr1) = HT then |
| Wchar (HT); |
| else |
| Wchar (' '); |
| end if; |
| |
| Ptr1 := Ptr1 + 1; |
| end loop; |
| |
| Wchar ('|'); |
| Write_Eol; |
| |
| Exit_Program (E_Fatal); |
| end Fatal_Error; |
| |
| -------------- |
| -- Get_Name -- |
| -------------- |
| |
| function Get_Name (Lower : Boolean := False) return Name_Id is |
| begin |
| Name_Len := 0; |
| Skip_Space; |
| |
| if At_Eol then |
| Fatal_Error; |
| end if; |
| |
| loop |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Getc; |
| exit when At_End_Of_Field |
| or else Nextc = ')' |
| or else Nextc = '}' |
| or else Nextc = '>' |
| or else Nextc = '='; |
| end loop; |
| |
| -- Convert file name to all lower case if file names are not case |
| -- sensitive. This ensures that we handle names in the canonical |
| -- lower case format, regardless of the actual case. |
| |
| if Lower and not File_Names_Case_Sensitive then |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| end if; |
| |
| return Name_Find; |
| end Get_Name; |
| |
| ------------- |
| -- Get_Nat -- |
| ------------- |
| |
| function Get_Nat return Nat is |
| V : Nat; |
| |
| begin |
| Skip_Space; |
| |
| V := 0; |
| |
| loop |
| V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0')); |
| exit when At_End_Of_Field; |
| exit when Nextc < '0' or Nextc > '9'; |
| end loop; |
| |
| return V; |
| end Get_Nat; |
| |
| --------------- |
| -- Get_Stamp -- |
| --------------- |
| |
| function Get_Stamp return Time_Stamp_Type is |
| T : Time_Stamp_Type; |
| Start : Integer; |
| |
| begin |
| Skip_Space; |
| |
| if At_Eol then |
| Fatal_Error; |
| end if; |
| |
| -- Following reads old style time stamp missing first two digits |
| |
| if Nextc in '7' .. '9' then |
| T (1) := '1'; |
| T (2) := '9'; |
| Start := 3; |
| |
| -- Normal case of full year in time stamp |
| |
| else |
| Start := 1; |
| end if; |
| |
| for J in Start .. T'Last loop |
| T (J) := Getc; |
| end loop; |
| |
| return T; |
| end Get_Stamp; |
| |
| ---------- |
| -- Getc -- |
| ---------- |
| |
| function Getc return Character is |
| begin |
| if P = T'Last then |
| return EOF; |
| else |
| P := P + 1; |
| return T (P - 1); |
| end if; |
| end Getc; |
| |
| ----------- |
| -- Nextc -- |
| ----------- |
| |
| function Nextc return Character is |
| begin |
| return T (P); |
| end Nextc; |
| |
| -------------- |
| -- Skip_Eol -- |
| -------------- |
| |
| procedure Skip_Eol is |
| begin |
| Skip_Space; |
| if not At_Eol then Fatal_Error; end if; |
| |
| -- Loop to skip past blank lines (first time through skips this EOL) |
| |
| while Nextc < ' ' and then Nextc /= EOF loop |
| if Nextc = LF then |
| Line := Line + 1; |
| end if; |
| |
| P := P + 1; |
| end loop; |
| end Skip_Eol; |
| |
| ---------------- |
| -- Skip_Space -- |
| ---------------- |
| |
| procedure Skip_Space is |
| begin |
| while Nextc = ' ' or else Nextc = HT loop |
| P := P + 1; |
| end loop; |
| end Skip_Space; |
| |
| -------------------------------------- |
| -- Start of processing for Scan_ALI -- |
| -------------------------------------- |
| |
| begin |
| ALIs.Increment_Last; |
| Id := ALIs.Last; |
| Set_Name_Table_Info (F, Int (Id)); |
| |
| ALIs.Table (Id) := ( |
| Afile => F, |
| Compile_Errors => False, |
| First_Sdep => No_Sdep_Id, |
| First_Unit => No_Unit_Id, |
| Float_Format => 'I', |
| Last_Sdep => No_Sdep_Id, |
| Last_Unit => No_Unit_Id, |
| Locking_Policy => ' ', |
| Main_Priority => -1, |
| Main_Program => None, |
| No_Object => False, |
| No_Run_Time => False, |
| Normalize_Scalars => False, |
| Ofile_Full_Name => Full_Object_File_Name, |
| Queuing_Policy => ' ', |
| Restrictions => (others => ' '), |
| Sfile => No_Name, |
| Task_Dispatching_Policy => ' ', |
| Time_Slice_Value => -1, |
| WC_Encoding => '8', |
| Unit_Exception_Table => False, |
| Ver => (others => ' '), |
| Ver_Len => 0, |
| Zero_Cost_Exceptions => False); |
| |
| -- Acquire library version |
| |
| Checkc ('V'); |
| Checkc (' '); |
| Skip_Space; |
| Checkc ('"'); |
| |
| for J in 1 .. Ver_Len_Max loop |
| C := Getc; |
| exit when C = '"'; |
| ALIs.Table (Id).Ver (J) := C; |
| ALIs.Table (Id).Ver_Len := J; |
| end loop; |
| |
| Skip_Eol; |
| |
| -- Acquire main program line if present |
| |
| C := Getc; |
| |
| if C = 'M' then |
| Checkc (' '); |
| Skip_Space; |
| |
| C := Getc; |
| |
| if C = 'F' then |
| ALIs.Table (Id).Main_Program := Func; |
| elsif C = 'P' then |
| ALIs.Table (Id).Main_Program := Proc; |
| else |
| P := P - 1; |
| Fatal_Error; |
| end if; |
| |
| Skip_Space; |
| |
| if not At_Eol then |
| if Nextc < 'A' then |
| ALIs.Table (Id).Main_Priority := Get_Nat; |
| end if; |
| |
| Skip_Space; |
| |
| if Nextc = 'T' then |
| P := P + 1; |
| Checkc ('='); |
| ALIs.Table (Id).Time_Slice_Value := Get_Nat; |
| end if; |
| |
| Skip_Space; |
| |
| Checkc ('W'); |
| Checkc ('='); |
| ALIs.Table (Id).WC_Encoding := Getc; |
| end if; |
| |
| Skip_Eol; |
| C := Getc; |
| |
| end if; |
| |
| -- Acquire argument lines |
| |
| First_Arg := Args.Last + 1; |
| |
| Arg_Loop : while C = 'A' loop |
| Checkc (' '); |
| Name_Len := 0; |
| |
| while not At_Eol loop |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Getc; |
| end loop; |
| |
| Args.Increment_Last; |
| Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); |
| |
| Skip_Eol; |
| C := Getc; |
| end loop Arg_Loop; |
| |
| -- Acquire P line, first set defaults |
| |
| if C /= 'P' then |
| Fatal_Error; |
| end if; |
| |
| NS_Found := False; |
| |
| while not At_Eol loop |
| Checkc (' '); |
| Skip_Space; |
| C := Getc; |
| |
| if C = 'C' then |
| Checkc ('E'); |
| ALIs.Table (Id).Compile_Errors := True; |
| |
| elsif C = 'F' then |
| Float_Format_Specified := Getc; |
| ALIs.Table (Id).Float_Format := Float_Format_Specified; |
| |
| elsif C = 'L' then |
| Locking_Policy_Specified := Getc; |
| ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified; |
| |
| elsif C = 'N' then |
| C := Getc; |
| |
| if C = 'O' then |
| ALIs.Table (Id).No_Object := True; |
| No_Object_Specified := True; |
| |
| elsif C = 'R' then |
| No_Run_Time_Specified := True; |
| ALIs.Table (Id).No_Run_Time := True; |
| |
| elsif C = 'S' then |
| ALIs.Table (Id).Normalize_Scalars := True; |
| Normalize_Scalars_Specified := True; |
| NS_Found := True; |
| |
| else |
| Fatal_Error; |
| end if; |
| |
| elsif C = 'Q' then |
| Queuing_Policy_Specified := Getc; |
| ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; |
| |
| elsif C = 'T' then |
| Task_Dispatching_Policy_Specified := Getc; |
| ALIs.Table (Id).Task_Dispatching_Policy := |
| Task_Dispatching_Policy_Specified; |
| |
| elsif C = 'U' then |
| if Nextc = 'A' then |
| Unreserve_All_Interrupts_Specified := True; |
| C := Getc; |
| |
| else |
| Checkc ('X'); |
| ALIs.Table (Id).Unit_Exception_Table := True; |
| end if; |
| |
| elsif C = 'Z' then |
| Checkc ('X'); |
| ALIs.Table (Id).Zero_Cost_Exceptions := True; |
| Zero_Cost_Exceptions_Specified := True; |
| |
| else |
| Fatal_Error; |
| end if; |
| end loop; |
| |
| if not NS_Found then |
| No_Normalize_Scalars_Specified := True; |
| end if; |
| |
| Skip_Eol; |
| |
| -- Acquire restrictions line |
| |
| if Getc /= 'R' then |
| Fatal_Error; |
| |
| else |
| Checkc (' '); |
| Skip_Space; |
| |
| for J in Partition_Restrictions loop |
| C := Getc; |
| |
| if C = 'v' or else C = 'r' or else C = 'n' then |
| ALIs.Table (Id).Restrictions (J) := C; |
| else |
| Fatal_Error; |
| end if; |
| end loop; |
| |
| if At_Eol then |
| Skip_Eol; |
| C := Getc; |
| else |
| Fatal_Error; |
| end if; |
| end if; |
| |
| -- Loop to acquire unit entries |
| |
| Unit_Loop : while C = 'U' loop |
| Checkc (' '); |
| Skip_Space; |
| Units.Increment_Last; |
| |
| if ALIs.Table (Id).First_Unit = No_Unit_Id then |
| ALIs.Table (Id).First_Unit := Units.Last; |
| end if; |
| |
| Units.Table (Units.Last).Uname := Get_Name; |
| Units.Table (Units.Last).Predefined := Is_Predefined_Unit; |
| Units.Table (Units.Last).Internal := Is_Internal_Unit; |
| Units.Table (Units.Last).My_ALI := Id; |
| Units.Table (Units.Last).Sfile := Get_Name (Lower => True); |
| Units.Table (Units.Last).Pure := False; |
| Units.Table (Units.Last).Preelab := False; |
| Units.Table (Units.Last).No_Elab := False; |
| Units.Table (Units.Last).Shared_Passive := False; |
| Units.Table (Units.Last).RCI := False; |
| Units.Table (Units.Last).Remote_Types := False; |
| Units.Table (Units.Last).Has_RACW := False; |
| Units.Table (Units.Last).Init_Scalars := False; |
| Units.Table (Units.Last).Is_Generic := False; |
| Units.Table (Units.Last).Icasing := Mixed_Case; |
| Units.Table (Units.Last).Kcasing := All_Lower_Case; |
| Units.Table (Units.Last).Dynamic_Elab := False; |
| Units.Table (Units.Last).Elaborate_Body := False; |
| Units.Table (Units.Last).Set_Elab_Entity := False; |
| Units.Table (Units.Last).Version := "00000000"; |
| Units.Table (Units.Last).First_With := Withs.Last + 1; |
| Units.Table (Units.Last).First_Arg := First_Arg; |
| Units.Table (Units.Last).Elab_Position := 0; |
| |
| if Debug_Flag_U then |
| Write_Str (" ----> reading unit "); |
| Write_Unit_Name (Units.Table (Units.Last).Uname); |
| Write_Str (" from file "); |
| Write_Name (Units.Table (Units.Last).Sfile); |
| Write_Eol; |
| end if; |
| |
| -- Check for duplicated unit in different files |
| |
| declare |
| Info : constant Int := Get_Name_Table_Info |
| (Units.Table (Units.Last).Uname); |
| begin |
| if Info /= 0 |
| and then Units.Table (Units.Last).Sfile /= |
| Units.Table (Unit_Id (Info)).Sfile |
| then |
| -- If Err is set then treat duplicate unit name as an instance |
| -- of a bad ALI format. This is the case of being called from |
| -- gnatmake, and the point is that if anything is wrong with |
| -- the ALI file, then gnatmake should just recompile. |
| |
| if Err then |
| raise Bad_ALI_Format; |
| |
| -- If Err is not set, then this is a fatal error |
| |
| else |
| Set_Standard_Error; |
| Write_Str ("error: duplicate unit name: "); |
| Write_Eol; |
| |
| Write_Str ("error: unit """); |
| Write_Unit_Name (Units.Table (Units.Last).Uname); |
| Write_Str (""" found in file """); |
| Write_Name_Decoded (Units.Table (Units.Last).Sfile); |
| Write_Char ('"'); |
| Write_Eol; |
| |
| Write_Str ("error: unit """); |
| Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); |
| Write_Str (""" found in file """); |
| Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); |
| Write_Char ('"'); |
| Write_Eol; |
| |
| Exit_Program (E_Fatal); |
| end if; |
| end if; |
| end; |
| |
| Set_Name_Table_Info |
| (Units.Table (Units.Last).Uname, Int (Units.Last)); |
| |
| -- Scan out possible version and other parameters |
| |
| loop |
| Skip_Space; |
| exit when At_Eol; |
| C := Getc; |
| |
| -- Version field |
| |
| if C in '0' .. '9' or else C in 'a' .. 'f' then |
| Units.Table (Units.Last).Version (1) := C; |
| |
| for J in 2 .. 8 loop |
| C := Getc; |
| Units.Table (Units.Last).Version (J) := C; |
| end loop; |
| |
| -- DE parameter (Dynamic elaboration checks |
| |
| elsif C = 'D' then |
| Checkc ('E'); |
| Check_At_End_Of_Field; |
| Units.Table (Units.Last).Dynamic_Elab := True; |
| Dynamic_Elaboration_Checks_Specified := True; |
| |
| -- EB/EE parameters |
| |
| elsif C = 'E' then |
| C := Getc; |
| |
| if C = 'B' then |
| Units.Table (Units.Last).Elaborate_Body := True; |
| |
| elsif C = 'E' then |
| Units.Table (Units.Last).Set_Elab_Entity := True; |
| |
| else |
| Fatal_Error; |
| end if; |
| |
| Check_At_End_Of_Field; |
| |
| -- GE parameter (generic) |
| |
| elsif C = 'G' then |
| Checkc ('E'); |
| Check_At_End_Of_Field; |
| Units.Table (Units.Last).Is_Generic := True; |
| |
| -- IL/IS/IU parameters |
| |
| elsif C = 'I' then |
| C := Getc; |
| |
| if C = 'L' then |
| Units.Table (Units.Last).Icasing := All_Lower_Case; |
| |
| elsif C = 'S' then |
| Units.Table (Units.Last).Init_Scalars := True; |
| Initialize_Scalars_Used := True; |
| |
| elsif C = 'U' then |
| Units.Table (Units.Last).Icasing := All_Upper_Case; |
| |
| else |
| Fatal_Error; |
| end if; |
| |
| Check_At_End_Of_Field; |
| |
| -- KM/KU parameters |
| |
| elsif C = 'K' then |
| C := Getc; |
| |
| if C = 'M' then |
| Units.Table (Units.Last).Kcasing := Mixed_Case; |
| |
| elsif C = 'U' then |
| Units.Table (Units.Last).Kcasing := All_Upper_Case; |
| |
| else |
| Fatal_Error; |
| end if; |
| |
| Check_At_End_Of_Field; |
| |
| -- NE parameter |
| |
| elsif C = 'N' then |
| Checkc ('E'); |
| Units.Table (Units.Last).No_Elab := True; |
| Check_At_End_Of_Field; |
| |
| -- PR/PU/PK parameters |
| |
| elsif C = 'P' then |
| C := Getc; |
| |
| -- PR parameter (preelaborate) |
| |
| if C = 'R' then |
| Units.Table (Units.Last).Preelab := True; |
| |
| -- PU parameter (pure) |
| |
| elsif C = 'U' then |
| Units.Table (Units.Last).Pure := True; |
| |
| -- PK indicates unit is package |
| |
| elsif C = 'K' then |
| Units.Table (Units.Last).Unit_Kind := 'p'; |
| |
| else |
| Fatal_Error; |
| end if; |
| |
| Check_At_End_Of_Field; |
| |
| -- RC/RT parameters |
| |
| elsif C = 'R' then |
| C := Getc; |
| |
| -- RC parameter (remote call interface) |
| |
| if C = 'C' then |
| Units.Table (Units.Last).RCI := True; |
| |
| -- RT parameter (remote types) |
| |
| elsif C = 'T' then |
| Units.Table (Units.Last).Remote_Types := True; |
| |
| -- RA parameter (remote access to class wide type) |
| |
| elsif C = 'A' then |
| Units.Table (Units.Last).Has_RACW := True; |
| |
| else |
| Fatal_Error; |
| end if; |
| |
| Check_At_End_Of_Field; |
| |
| elsif C = 'S' then |
| C := Getc; |
| |
| -- SP parameter (shared passive) |
| |
| if C = 'P' then |
| Units.Table (Units.Last).Shared_Passive := True; |
| |
| -- SU parameter indicates unit is subprogram |
| |
| elsif C = 'U' then |
| Units.Table (Units.Last).Unit_Kind := 's'; |
| |
| else |
| Fatal_Error; |
| end if; |
| |
| Check_At_End_Of_Field; |
| |
| else |
| Fatal_Error; |
| end if; |
| |
| end loop; |
| |
| Skip_Eol; |
| |
| -- Check if static elaboration model used |
| |
| if not Units.Table (Units.Last).Dynamic_Elab |
| and then not Units.Table (Units.Last).Internal |
| then |
| Static_Elaboration_Model_Used := True; |
| end if; |
| |
| -- Scan out With lines for this unit |
| |
| C := Getc; |
| |
| With_Loop : while C = 'W' loop |
| Checkc (' '); |
| Skip_Space; |
| Withs.Increment_Last; |
| Withs.Table (Withs.Last).Uname := Get_Name; |
| Withs.Table (Withs.Last).Elaborate := False; |
| Withs.Table (Withs.Last).Elaborate_All := False; |
| Withs.Table (Withs.Last).Elab_All_Desirable := False; |
| |
| -- Generic case with no object file available |
| |
| if At_Eol then |
| Withs.Table (Withs.Last).Sfile := No_File; |
| Withs.Table (Withs.Last).Afile := No_File; |
| |
| -- Normal case |
| |
| else |
| Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True); |
| Withs.Table (Withs.Last).Afile := Get_Name; |
| |
| -- Scan out possible E, EA, and NE parameters |
| |
| while not At_Eol loop |
| Skip_Space; |
| |
| if Nextc = 'E' then |
| P := P + 1; |
| |
| if At_End_Of_Field then |
| Withs.Table (Withs.Last).Elaborate := True; |
| |
| elsif Nextc = 'A' then |
| P := P + 1; |
| Check_At_End_Of_Field; |
| Withs.Table (Withs.Last).Elaborate_All := True; |
| |
| else |
| Checkc ('D'); |
| Check_At_End_Of_Field; |
| |
| -- Store ED indication unless ignore required |
| |
| if not Ignore_ED then |
| Withs.Table (Withs.Last).Elab_All_Desirable := True; |
| end if; |
| end if; |
| end if; |
| end loop; |
| end if; |
| |
| Skip_Eol; |
| C := Getc; |
| |
| end loop With_Loop; |
| |
| Units.Table (Units.Last).Last_With := Withs.Last; |
| Units.Table (Units.Last).Last_Arg := Args.Last; |
| |
| end loop Unit_Loop; |
| |
| -- End loop through units for one ALI file |
| |
| ALIs.Table (Id).Last_Unit := Units.Last; |
| ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; |
| |
| -- Set types of the units (there can be at most 2 of them) |
| |
| if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then |
| Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; |
| Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; |
| |
| else |
| -- Deal with body only and spec only cases, note that the reason we |
| -- do our own checking of the name (rather than using Is_Body_Name) |
| -- is that Uname drags in far too much compiler junk! |
| |
| Get_Name_String (Units.Table (Units.Last).Uname); |
| |
| if Name_Buffer (Name_Len) = 'b' then |
| Units.Table (Units.Last).Utype := Is_Body_Only; |
| else |
| Units.Table (Units.Last).Utype := Is_Spec_Only; |
| end if; |
| end if; |
| |
| -- If there are linker options lines present, scan them |
| |
| while C = 'L' loop |
| Checkc (' '); |
| Skip_Space; |
| Checkc ('"'); |
| |
| Name_Len := 0; |
| loop |
| C := Getc; |
| |
| if C < Character'Val (16#20#) |
| or else C > Character'Val (16#7E#) |
| then |
| Fatal_Error; |
| |
| elsif C = '{' then |
| C := Character'Val (0); |
| |
| declare |
| V : Natural; |
| |
| begin |
| V := 0; |
| for J in 1 .. 2 loop |
| C := Getc; |
| |
| if C in '0' .. '9' then |
| V := V * 16 + |
| Character'Pos (C) - Character'Pos ('0'); |
| |
| elsif C in 'A' .. 'F' then |
| V := V * 16 + |
| Character'Pos (C) - Character'Pos ('A') + 10; |
| |
| else |
| Fatal_Error; |
| end if; |
| end loop; |
| |
| Checkc ('}'); |
| |
| Add_Char_To_Name_Buffer (Character'Val (V)); |
| end; |
| |
| else |
| if C = '"' then |
| exit when Nextc /= '"'; |
| C := Getc; |
| end if; |
| |
| Add_Char_To_Name_Buffer (C); |
| end if; |
| end loop; |
| |
| Add_Char_To_Name_Buffer (nul); |
| |
| Skip_Eol; |
| C := Getc; |
| |
| Linker_Options.Increment_Last; |
| |
| Linker_Options.Table (Linker_Options.Last).Name |
| := Name_Enter; |
| |
| Linker_Options.Table (Linker_Options.Last).Unit |
| := ALIs.Table (Id).First_Unit; |
| |
| Linker_Options.Table (Linker_Options.Last).Internal_File |
| := Is_Internal_File_Name (F); |
| |
| Linker_Options.Table (Linker_Options.Last).Original_Pos |
| := Linker_Options.Last; |
| |
| end loop; |
| |
| -- Scan out external version references and put in hash table |
| |
| while C = 'E' loop |
| Checkc (' '); |
| Skip_Space; |
| |
| Name_Len := 0; |
| Name_Len := 0; |
| loop |
| C := Getc; |
| |
| if C < ' ' then |
| Fatal_Error; |
| end if; |
| |
| exit when At_End_Of_Field; |
| Add_Char_To_Name_Buffer (C); |
| end loop; |
| |
| Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True); |
| Skip_Eol; |
| C := Getc; |
| end loop; |
| |
| -- Scan out source dependency lines for this ALI file |
| |
| ALIs.Table (Id).First_Sdep := Sdep.Last + 1; |
| |
| while C = 'D' loop |
| Checkc (' '); |
| Skip_Space; |
| Sdep.Increment_Last; |
| Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True); |
| Sdep.Table (Sdep.Last).Stamp := Get_Stamp; |
| Sdep.Table (Sdep.Last).Dummy_Entry := |
| (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp); |
| |
| -- Acquire checksum value |
| |
| Skip_Space; |
| |
| declare |
| Ctr : Natural; |
| Chk : Word; |
| |
| begin |
| Ctr := 0; |
| Chk := 0; |
| |
| loop |
| exit when At_Eol or else Ctr = 8; |
| |
| if Nextc in '0' .. '9' then |
| Chk := Chk * 16 + |
| Character'Pos (Nextc) - Character'Pos ('0'); |
| |
| elsif Nextc in 'a' .. 'f' then |
| Chk := Chk * 16 + |
| Character'Pos (Nextc) - Character'Pos ('a') + 10; |
| |
| else |
| exit; |
| end if; |
| |
| Ctr := Ctr + 1; |
| P := P + 1; |
| end loop; |
| |
| if Ctr = 8 and then At_End_Of_Field then |
| Sdep.Table (Sdep.Last).Checksum := Chk; |
| else |
| Fatal_Error; |
| end if; |
| end; |
| |
| -- Acquire subunit and reference file name entries |
| |
| Sdep.Table (Sdep.Last).Subunit_Name := No_Name; |
| Sdep.Table (Sdep.Last).Rfile := Sdep.Table (Sdep.Last).Sfile; |
| Sdep.Table (Sdep.Last).Start_Line := 1; |
| |
| if not At_Eol then |
| Skip_Space; |
| |
| -- Here for subunit name |
| |
| if Nextc not in '0' .. '9' then |
| Name_Len := 0; |
| |
| while not At_End_Of_Field loop |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Getc; |
| end loop; |
| |
| Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter; |
| Skip_Space; |
| end if; |
| |
| -- Here for reference file name entry |
| |
| if Nextc in '0' .. '9' then |
| Sdep.Table (Sdep.Last).Start_Line := Get_Nat; |
| Checkc (':'); |
| |
| Name_Len := 0; |
| |
| while not At_End_Of_Field loop |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Getc; |
| end loop; |
| |
| Sdep.Table (Sdep.Last).Rfile := Name_Enter; |
| end if; |
| end if; |
| |
| Skip_Eol; |
| C := Getc; |
| end loop; |
| |
| ALIs.Table (Id).Last_Sdep := Sdep.Last; |
| |
| -- Loop through Xref sections (skip loop if not reading xref stuff) |
| |
| while Read_Xref and then C = 'X' loop |
| |
| -- Make new entry in section table |
| |
| Xref_Section.Increment_Last; |
| |
| Read_Refs_For_One_File : declare |
| XS : Xref_Section_Record renames |
| Xref_Section.Table (Xref_Section.Last); |
| |
| Current_File_Num : Sdep_Id; |
| -- Keeps track of the current file number (changed by nn|) |
| |
| begin |
| XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1); |
| XS.File_Name := Get_Name; |
| XS.First_Entity := Xref_Entity.Last + 1; |
| |
| Current_File_Num := XS.File_Num; |
| |
| Skip_Eol; |
| C := Nextc; |
| |
| -- Loop through Xref entities |
| |
| while C /= 'X' and then C /= EOF loop |
| Xref_Entity.Increment_Last; |
| |
| Read_Refs_For_One_Entity : declare |
| |
| XE : Xref_Entity_Record renames |
| Xref_Entity.Table (Xref_Entity.Last); |
| |
| N : Nat; |
| |
| procedure Read_Instantiation_Reference; |
| -- Acquire instantiation reference. Caller has checked |
| -- that current character is '[' and on return the cursor |
| -- is skipped past the corresponding closing ']'. |
| |
| ---------------------------------- |
| -- Read_Instantiation_Reference -- |
| ---------------------------------- |
| |
| procedure Read_Instantiation_Reference is |
| begin |
| Xref.Increment_Last; |
| |
| declare |
| XR : Xref_Record renames Xref.Table (Xref.Last); |
| |
| begin |
| P := P + 1; -- skip [ |
| N := Get_Nat; |
| |
| if Nextc = '|' then |
| XR.File_Num := |
| Sdep_Id (N + Nat (First_Sdep_Entry) - 1); |
| Current_File_Num := XR.File_Num; |
| P := P + 1; |
| N := Get_Nat; |
| |
| else |
| XR.File_Num := Current_File_Num; |
| end if; |
| |
| XR.Line := N; |
| XR.Rtype := ' '; |
| XR.Col := 0; |
| |
| -- Recursive call for next reference |
| |
| if Nextc = '[' then |
| pragma Warnings (Off); -- kill recursion warning |
| Read_Instantiation_Reference; |
| pragma Warnings (On); |
| end if; |
| |
| -- Skip closing bracket after recursive call |
| |
| P := P + 1; |
| end; |
| end Read_Instantiation_Reference; |
| |
| -- Start of processing for Read_Refs_For_One_Entity |
| |
| begin |
| XE.Line := Get_Nat; |
| XE.Etype := Getc; |
| XE.Col := Get_Nat; |
| XE.Lib := (Getc = '*'); |
| XE.Entity := Get_Name; |
| |
| -- Renaming reference is present |
| |
| if Nextc = '=' then |
| P := P + 1; |
| XE.Rref_Line := Get_Nat; |
| |
| if Getc /= ':' then |
| Fatal_Error; |
| end if; |
| |
| XE.Rref_Col := Get_Nat; |
| |
| -- No renaming reference present |
| |
| else |
| XE.Rref_Line := 0; |
| XE.Rref_Col := 0; |
| end if; |
| |
| Skip_Space; |
| |
| -- See if type reference present |
| |
| case Nextc is |
| when '<' => XE.Tref := Tref_Derived; |
| when '(' => XE.Tref := Tref_Access; |
| when '{' => XE.Tref := Tref_Type; |
| when others => XE.Tref := Tref_None; |
| end case; |
| |
| -- Case of typeref field present |
| |
| if XE.Tref /= Tref_None then |
| P := P + 1; -- skip opening bracket |
| |
| if Nextc in 'a' .. 'z' then |
| XE.Tref_File_Num := No_Sdep_Id; |
| XE.Tref_Line := 0; |
| XE.Tref_Type := ' '; |
| XE.Tref_Col := 0; |
| XE.Tref_Standard_Entity := Get_Name; |
| |
| else |
| N := Get_Nat; |
| |
| if Nextc = '|' then |
| XE.Tref_File_Num := |
| Sdep_Id (N + Nat (First_Sdep_Entry) - 1); |
| P := P + 1; |
| N := Get_Nat; |
| |
| else |
| XE.Tref_File_Num := Current_File_Num; |
| end if; |
| |
| XE.Tref_Line := N; |
| XE.Tref_Type := Getc; |
| XE.Tref_Col := Get_Nat; |
| XE.Tref_Standard_Entity := No_Name; |
| end if; |
| |
| P := P + 1; -- skip closing bracket |
| Skip_Space; |
| |
| -- No typeref entry present |
| |
| else |
| XE.Tref_File_Num := No_Sdep_Id; |
| XE.Tref_Line := 0; |
| XE.Tref_Type := ' '; |
| XE.Tref_Col := 0; |
| XE.Tref_Standard_Entity := No_Name; |
| end if; |
| |
| XE.First_Xref := Xref.Last + 1; |
| |
| -- Loop through cross-references for this entity |
| |
| Current_File_Num := XS.File_Num; |
| |
| loop |
| Skip_Space; |
| |
| if At_Eol then |
| Skip_Eol; |
| exit when Nextc /= '.'; |
| P := P + 1; |
| end if; |
| |
| Xref.Increment_Last; |
| |
| declare |
| XR : Xref_Record renames Xref.Table (Xref.Last); |
| |
| begin |
| N := Get_Nat; |
| |
| if Nextc = '|' then |
| XR.File_Num := |
| Sdep_Id (N + Nat (First_Sdep_Entry) - 1); |
| Current_File_Num := XR.File_Num; |
| P := P + 1; |
| N := Get_Nat; |
| |
| else |
| XR.File_Num := Current_File_Num; |
| end if; |
| |
| XR.Line := N; |
| XR.Rtype := Getc; |
| XR.Col := Get_Nat; |
| |
| if Nextc = '[' then |
| Read_Instantiation_Reference; |
| end if; |
| end; |
| end loop; |
| |
| -- Record last cross-reference |
| |
| XE.Last_Xref := Xref.Last; |
| C := Nextc; |
| |
| end Read_Refs_For_One_Entity; |
| end loop; |
| |
| -- Record last entity |
| |
| XS.Last_Entity := Xref_Entity.Last; |
| |
| end Read_Refs_For_One_File; |
| |
| C := Getc; |
| end loop; |
| |
| -- Here after dealing with xref sections |
| |
| if C /= EOF and then C /= 'X' then |
| Fatal_Error; |
| end if; |
| |
| return Id; |
| |
| exception |
| when Bad_ALI_Format => |
| return No_ALI_Id; |
| |
| end Scan_ALI; |
| |
| --------- |
| -- SEq -- |
| --------- |
| |
| function SEq (F1, F2 : String_Ptr) return Boolean is |
| begin |
| return F1.all = F2.all; |
| end SEq; |
| |
| ----------- |
| -- SHash -- |
| ----------- |
| |
| function SHash (S : String_Ptr) return Vindex is |
| H : Word; |
| |
| begin |
| H := 0; |
| for J in S.all'Range loop |
| H := H * 2 + Character'Pos (S (J)); |
| end loop; |
| |
| return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length)); |
| end SHash; |
| |
| end ALI; |
