Mercurial > hg > CbC > CbC_gcc
view gcc/ada/ali.adb @ 145:1830386684a0
gcc-9.2.0
| author | anatofuz |
|---|---|
| date | Thu, 13 Feb 2020 11:34:05 +0900 |
| parents | 84e7813d76e9 |
| children |
line wrap: on
line source
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A L I -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2019, 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 3, 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 COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Butil; use Butil; with Debug; use Debug; with Fname; use Fname; with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Snames; use Snames; with GNAT; use GNAT; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; package body ALI is use ASCII; -- Make control characters visible ----------- -- Types -- ----------- -- The following type represents an invocation construct type Invocation_Construct_Record is record Body_Placement : Declaration_Placement_Kind := No_Declaration_Placement; -- The location of the invocation construct's body with respect to the -- unit where it is declared. Kind : Invocation_Construct_Kind := Regular_Construct; -- The nature of the invocation construct Signature : Invocation_Signature_Id := No_Invocation_Signature; -- The invocation signature that uniquely identifies the invocation -- construct in the ALI space. Spec_Placement : Declaration_Placement_Kind := No_Declaration_Placement; -- The location of the invocation construct's spec with respect to the -- unit where it is declared. end record; -- The following type represents an invocation relation. It associates an -- invoker that activates/calls/instantiates with a target. type Invocation_Relation_Record is record Extra : Name_Id := No_Name; -- The name of an additional entity used in error diagnostics Invoker : Invocation_Signature_Id := No_Invocation_Signature; -- The invocation signature that uniquely identifies the invoker within -- the ALI space. Kind : Invocation_Kind := No_Invocation; -- The nature of the invocation Target : Invocation_Signature_Id := No_Invocation_Signature; -- The invocation signature that uniquely identifies the target within -- the ALI space. end record; -- The following type represents an invocation signature. Its purpose is -- to uniquely identify an invocation construct within the ALI space. The -- signature comprises several pieces, some of which are used in error -- diagnostics by the binder. Identification issues are resolved as -- follows: -- -- * The Column, Line, and Locations attributes together differentiate -- between homonyms. In most cases, the Column and Line are sufficient -- except when generic instantiations are involved. Together, the three -- attributes offer a sequence of column-line pairs that eventually -- reflect the location within the generic template. -- -- * The Name attribute differentiates between invocation constructs at -- the scope level. Since it is illegal for two entities with the same -- name to coexist in the same scope, the Name attribute is sufficient -- to distinguish them. Overloaded entities are already handled by the -- Column, Line, and Locations attributes. -- -- * The Scope attribute differentiates between invocation constructs at -- various levels of nesting. type Invocation_Signature_Record is record Column : Nat := 0; -- The column number where the invocation construct is declared Line : Nat := 0; -- The line number where the invocation construct is declared Locations : Name_Id := No_Name; -- Sequence of column and line numbers within nested instantiations Name : Name_Id := No_Name; -- The name of the invocation construct Scope : Name_Id := No_Name; -- The qualified name of the scope where the invocation construct is -- declared. end record; --------------------- -- Data structures -- --------------------- package Invocation_Constructs is new Table.Table (Table_Index_Type => Invocation_Construct_Id, Table_Component_Type => Invocation_Construct_Record, Table_Low_Bound => First_Invocation_Construct, Table_Initial => 2500, Table_Increment => 200, Table_Name => "Invocation_Constructs"); package Invocation_Relations is new Table.Table (Table_Index_Type => Invocation_Relation_Id, Table_Component_Type => Invocation_Relation_Record, Table_Low_Bound => First_Invocation_Relation, Table_Initial => 2500, Table_Increment => 200, Table_Name => "Invocation_Relation"); package Invocation_Signatures is new Table.Table (Table_Index_Type => Invocation_Signature_Id, Table_Component_Type => Invocation_Signature_Record, Table_Low_Bound => First_Invocation_Signature, Table_Initial => 2500, Table_Increment => 200, Table_Name => "Invocation_Signatures"); procedure Destroy (IS_Id : in out Invocation_Signature_Id); -- Destroy an invocation signature with id IS_Id function Hash (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type; -- Obtain the hash of key IS_Rec package Sig_Map is new Dynamic_Hash_Tables (Key_Type => Invocation_Signature_Record, Value_Type => Invocation_Signature_Id, No_Value => No_Invocation_Signature, Expansion_Threshold => 1.5, Expansion_Factor => 2, Compression_Threshold => 0.3, Compression_Factor => 2, "=" => "=", Destroy_Value => Destroy, Hash => Hash); -- The following map relates invocation signature records to invocation -- signature ids. Sig_To_Sig_Map : constant Sig_Map.Dynamic_Hash_Table := Sig_Map.Create (500); -- The folowing table maps declaration placement kinds to character codes -- for invocation construct encoding in ALI files. Declaration_Placement_Codes : constant array (Declaration_Placement_Kind) of Character := (In_Body => 'b', In_Spec => 's', No_Declaration_Placement => 'Z'); Compile_Time_Invocation_Graph_Encoding : Invocation_Graph_Encoding_Kind := No_Encoding; -- The invocation-graph encoding format as specified at compile time. Do -- not manipulate this value directly. -- The following table maps invocation kinds to character codes for -- invocation relation encoding in ALI files. Invocation_Codes : constant array (Invocation_Kind) of Character := (Accept_Alternative => 'a', Access_Taken => 'b', Call => 'c', Controlled_Adjustment => 'd', Controlled_Finalization => 'e', Controlled_Initialization => 'f', Default_Initial_Condition_Verification => 'g', Initial_Condition_Verification => 'h', Instantiation => 'i', Internal_Controlled_Adjustment => 'j', Internal_Controlled_Finalization => 'k', Internal_Controlled_Initialization => 'l', Invariant_Verification => 'm', Postcondition_Verification => 'n', Protected_Entry_Call => 'o', Protected_Subprogram_Call => 'p', Task_Activation => 'q', Task_Entry_Call => 'r', Type_Initialization => 's', No_Invocation => 'Z'); -- The following table maps invocation construct kinds to character codes -- for invocation construct encoding in ALI files. Invocation_Construct_Codes : constant array (Invocation_Construct_Kind) of Character := (Elaborate_Body_Procedure => 'b', Elaborate_Spec_Procedure => 's', Regular_Construct => 'Z'); -- The following table maps invocation-graph encoding kinds to character -- codes for invocation-graph encoding in ALI files. Invocation_Graph_Encoding_Codes : constant array (Invocation_Graph_Encoding_Kind) of Character := (Full_Path_Encoding => 'f', Endpoints_Encoding => 'e', No_Encoding => 'Z'); -- The following table maps invocation-graph line kinds to character codes -- used in ALI files. Invocation_Graph_Line_Codes : constant array (Invocation_Graph_Line_Kind) of Character := (Invocation_Construct_Line => 'c', Invocation_Graph_Attributes_Line => 'a', Invocation_Relation_Line => 'r'); -- The following variable records which characters currently are used as -- line type markers in the ALI file. This is used in Scan_ALI to detect -- (or skip) invalid lines. The following letters are still available: -- -- B F H J K O Q Z Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := ('A' => True, -- argument 'C' => True, -- SCO information 'D' => True, -- dependency 'E' => True, -- external 'G' => True, -- invocation graph 'I' => True, -- interrupt 'L' => True, -- linker option 'M' => True, -- main program 'N' => True, -- notes 'P' => True, -- program 'R' => True, -- restriction 'S' => True, -- specific dispatching 'T' => True, -- task stack information 'U' => True, -- unit 'V' => True, -- version 'W' => True, -- with 'X' => True, -- xref 'Y' => True, -- limited_with 'Z' => True, -- implicit with from instantiation others => False); ------------------------------ -- Add_Invocation_Construct -- ------------------------------ procedure Add_Invocation_Construct (Body_Placement : Declaration_Placement_Kind; Kind : Invocation_Construct_Kind; Signature : Invocation_Signature_Id; Spec_Placement : Declaration_Placement_Kind; Update_Units : Boolean := True) is begin pragma Assert (Present (Signature)); -- Create a invocation construct from the scanned attributes Invocation_Constructs.Append ((Body_Placement => Body_Placement, Kind => Kind, Signature => Signature, Spec_Placement => Spec_Placement)); -- Update the invocation construct counter of the current unit only when -- requested by the caller. if Update_Units then declare Curr_Unit : Unit_Record renames Units.Table (Units.Last); begin Curr_Unit.Last_Invocation_Construct := Invocation_Constructs.Last; end; end if; end Add_Invocation_Construct; ----------------------------- -- Add_Invocation_Relation -- ----------------------------- procedure Add_Invocation_Relation (Extra : Name_Id; Invoker : Invocation_Signature_Id; Kind : Invocation_Kind; Target : Invocation_Signature_Id; Update_Units : Boolean := True) is begin pragma Assert (Present (Invoker)); pragma Assert (Kind /= No_Invocation); pragma Assert (Present (Target)); -- Create an invocation relation from the scanned attributes Invocation_Relations.Append ((Extra => Extra, Invoker => Invoker, Kind => Kind, Target => Target)); -- Update the invocation relation counter of the current unit only when -- requested by the caller. if Update_Units then declare Curr_Unit : Unit_Record renames Units.Table (Units.Last); begin Curr_Unit.Last_Invocation_Relation := Invocation_Relations.Last; end; end if; end Add_Invocation_Relation; -------------------- -- Body_Placement -- -------------------- function Body_Placement (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind is begin pragma Assert (Present (IC_Id)); return Invocation_Constructs.Table (IC_Id).Body_Placement; end Body_Placement; ---------------------------------------- -- Code_To_Declaration_Placement_Kind -- ---------------------------------------- function Code_To_Declaration_Placement_Kind (Code : Character) return Declaration_Placement_Kind is begin -- Determine which placement kind corresponds to the character code by -- traversing the contents of the mapping table. for Kind in Declaration_Placement_Kind loop if Declaration_Placement_Codes (Kind) = Code then return Kind; end if; end loop; raise Program_Error; end Code_To_Declaration_Placement_Kind; --------------------------------------- -- Code_To_Invocation_Construct_Kind -- --------------------------------------- function Code_To_Invocation_Construct_Kind (Code : Character) return Invocation_Construct_Kind is begin -- Determine which invocation construct kind matches the character code -- by traversing the contents of the mapping table. for Kind in Invocation_Construct_Kind loop if Invocation_Construct_Codes (Kind) = Code then return Kind; end if; end loop; raise Program_Error; end Code_To_Invocation_Construct_Kind; -------------------------------------------- -- Code_To_Invocation_Graph_Encoding_Kind -- -------------------------------------------- function Code_To_Invocation_Graph_Encoding_Kind (Code : Character) return Invocation_Graph_Encoding_Kind is begin -- Determine which invocation-graph encoding kind matches the character -- code by traversing the contents of the mapping table. for Kind in Invocation_Graph_Encoding_Kind loop if Invocation_Graph_Encoding_Codes (Kind) = Code then return Kind; end if; end loop; raise Program_Error; end Code_To_Invocation_Graph_Encoding_Kind; ----------------------------- -- Code_To_Invocation_Kind -- ----------------------------- function Code_To_Invocation_Kind (Code : Character) return Invocation_Kind is begin -- Determine which invocation kind corresponds to the character code by -- traversing the contents of the mapping table. for Kind in Invocation_Kind loop if Invocation_Codes (Kind) = Code then return Kind; end if; end loop; raise Program_Error; end Code_To_Invocation_Kind; ---------------------------------------- -- Code_To_Invocation_Graph_Line_Kind -- ---------------------------------------- function Code_To_Invocation_Graph_Line_Kind (Code : Character) return Invocation_Graph_Line_Kind is begin -- Determine which invocation-graph line kind matches the character -- code by traversing the contents of the mapping table. for Kind in Invocation_Graph_Line_Kind loop if Invocation_Graph_Line_Codes (Kind) = Code then return Kind; end if; end loop; raise Program_Error; end Code_To_Invocation_Graph_Line_Kind; ------------ -- Column -- ------------ function Column (IS_Id : Invocation_Signature_Id) return Nat is begin pragma Assert (Present (IS_Id)); return Invocation_Signatures.Table (IS_Id).Column; end Column; ---------------------------------------- -- Declaration_Placement_Kind_To_Code -- ---------------------------------------- function Declaration_Placement_Kind_To_Code (Kind : Declaration_Placement_Kind) return Character is begin return Declaration_Placement_Codes (Kind); end Declaration_Placement_Kind_To_Code; ------------- -- Destroy -- ------------- procedure Destroy (IS_Id : in out Invocation_Signature_Id) is pragma Unreferenced (IS_Id); begin null; end Destroy; ----------- -- Extra -- ----------- function Extra (IR_Id : Invocation_Relation_Id) return Name_Id is begin pragma Assert (Present (IR_Id)); return Invocation_Relations.Table (IR_Id).Extra; end Extra; ----------------------------------- -- For_Each_Invocation_Construct -- ----------------------------------- procedure For_Each_Invocation_Construct (Processor : Invocation_Construct_Processor_Ptr) is begin pragma Assert (Processor /= null); for IC_Id in Invocation_Constructs.First .. Invocation_Constructs.Last loop Processor.all (IC_Id); end loop; end For_Each_Invocation_Construct; ----------------------------------- -- For_Each_Invocation_Construct -- ----------------------------------- procedure For_Each_Invocation_Construct (U_Id : Unit_Id; Processor : Invocation_Construct_Processor_Ptr) is pragma Assert (Present (U_Id)); pragma Assert (Processor /= null); U_Rec : Unit_Record renames Units.Table (U_Id); begin for IC_Id in U_Rec.First_Invocation_Construct .. U_Rec.Last_Invocation_Construct loop Processor.all (IC_Id); end loop; end For_Each_Invocation_Construct; ---------------------------------- -- For_Each_Invocation_Relation -- ---------------------------------- procedure For_Each_Invocation_Relation (Processor : Invocation_Relation_Processor_Ptr) is begin pragma Assert (Processor /= null); for IR_Id in Invocation_Relations.First .. Invocation_Relations.Last loop Processor.all (IR_Id); end loop; end For_Each_Invocation_Relation; ---------------------------------- -- For_Each_Invocation_Relation -- ---------------------------------- procedure For_Each_Invocation_Relation (U_Id : Unit_Id; Processor : Invocation_Relation_Processor_Ptr) is pragma Assert (Present (U_Id)); pragma Assert (Processor /= null); U_Rec : Unit_Record renames Units.Table (U_Id); begin for IR_Id in U_Rec.First_Invocation_Relation .. U_Rec.Last_Invocation_Relation loop Processor.all (IR_Id); end loop; end For_Each_Invocation_Relation; ---------- -- Hash -- ---------- function Hash (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type is Buffer : Bounded_String (2052); IS_Nam : Name_Id; begin -- The hash is obtained in the following manner: -- -- * A String signature based on the scope, name, line number, column -- number, and locations, in the following format: -- -- scope__name__line_column__locations -- -- * The String is converted into a Name_Id -- * The Name_Id is used as the hash Append (Buffer, IS_Rec.Scope); Append (Buffer, "__"); Append (Buffer, IS_Rec.Name); Append (Buffer, "__"); Append (Buffer, IS_Rec.Line); Append (Buffer, '_'); Append (Buffer, IS_Rec.Column); if IS_Rec.Locations /= No_Name then Append (Buffer, "__"); Append (Buffer, IS_Rec.Locations); end if; IS_Nam := Name_Find (Buffer); return Bucket_Range_Type (IS_Nam); end Hash; -------------------- -- 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. -- These two loops are empty and harmless the first time in. for J in ALIs.First .. ALIs.Last loop Set_Name_Table_Int (ALIs.Table (J).Afile, 0); end loop; for J in Units.First .. Units.Last loop Set_Name_Table_Int (Units.Table (J).Uname, 0); end loop; -- Free argument table strings for J in Args.First .. Args.Last loop Free (Args.Table (J)); end loop; -- Initialize all tables ALIs.Init; Invocation_Constructs.Init; Invocation_Relations.Init; Invocation_Signatures.Init; Linker_Options.Init; No_Deps.Init; Notes.Init; Sdep.Init; Units.Init; Version_Ref.Reset; Withs.Init; Xref_Entity.Init; Xref.Init; Xref_Section.Init; -- Add dummy zeroth item in Linker_Options and Notes for sort calls Linker_Options.Increment_Last; Notes.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; Locking_Policy_Specified := ' '; No_Normalize_Scalars_Specified := False; No_Object_Specified := False; No_Component_Reordering_Specified := False; GNATprove_Mode_Specified := False; Normalize_Scalars_Specified := False; Partition_Elaboration_Policy_Specified := ' '; Queuing_Policy_Specified := ' '; SSO_Default_Specified := False; Task_Dispatching_Policy_Specified := ' '; Unreserve_All_Interrupts_Specified := False; Frontend_Exceptions_Specified := False; Zero_Cost_Exceptions_Specified := False; end Initialize_ALI; --------------------------------------- -- Invocation_Construct_Kind_To_Code -- --------------------------------------- function Invocation_Construct_Kind_To_Code (Kind : Invocation_Construct_Kind) return Character is begin return Invocation_Construct_Codes (Kind); end Invocation_Construct_Kind_To_Code; ------------------------------- -- Invocation_Graph_Encoding -- ------------------------------- function Invocation_Graph_Encoding return Invocation_Graph_Encoding_Kind is begin return Compile_Time_Invocation_Graph_Encoding; end Invocation_Graph_Encoding; -------------------------------------------- -- Invocation_Graph_Encoding_Kind_To_Code -- -------------------------------------------- function Invocation_Graph_Encoding_Kind_To_Code (Kind : Invocation_Graph_Encoding_Kind) return Character is begin return Invocation_Graph_Encoding_Codes (Kind); end Invocation_Graph_Encoding_Kind_To_Code; ---------------------------------------- -- Invocation_Graph_Line_Kind_To_Code -- ---------------------------------------- function Invocation_Graph_Line_Kind_To_Code (Kind : Invocation_Graph_Line_Kind) return Character is begin return Invocation_Graph_Line_Codes (Kind); end Invocation_Graph_Line_Kind_To_Code; ----------------------------- -- Invocation_Kind_To_Code -- ----------------------------- function Invocation_Kind_To_Code (Kind : Invocation_Kind) return Character is begin return Invocation_Codes (Kind); end Invocation_Kind_To_Code; ----------------------------- -- Invocation_Signature_Of -- ----------------------------- function Invocation_Signature_Of (Column : Nat; Line : Nat; Locations : Name_Id; Name : Name_Id; Scope : Name_Id) return Invocation_Signature_Id is IS_Rec : constant Invocation_Signature_Record := (Column => Column, Line => Line, Locations => Locations, Name => Name, Scope => Scope); IS_Id : Invocation_Signature_Id; begin IS_Id := Sig_Map.Get (Sig_To_Sig_Map, IS_Rec); -- The invocation signature lacks an id. This indicates that it -- is encountered for the first time during the construction of -- the graph. if not Present (IS_Id) then Invocation_Signatures.Append (IS_Rec); IS_Id := Invocation_Signatures.Last; -- Map the invocation signature record to its corresponding id Sig_Map.Put (Sig_To_Sig_Map, IS_Rec, IS_Id); end if; return IS_Id; end Invocation_Signature_Of; ------------- -- Invoker -- ------------- function Invoker (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id is begin pragma Assert (Present (IR_Id)); return Invocation_Relations.Table (IR_Id).Invoker; end Invoker; ---------- -- Kind -- ---------- function Kind (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind is begin pragma Assert (Present (IC_Id)); return Invocation_Constructs.Table (IC_Id).Kind; end Kind; ---------- -- Kind -- ---------- function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind is begin pragma Assert (Present (IR_Id)); return Invocation_Relations.Table (IR_Id).Kind; end Kind; ---------- -- Line -- ---------- function Line (IS_Id : Invocation_Signature_Id) return Nat is begin pragma Assert (Present (IS_Id)); return Invocation_Signatures.Table (IS_Id).Line; end Line; --------------- -- Locations -- --------------- function Locations (IS_Id : Invocation_Signature_Id) return Name_Id is begin pragma Assert (Present (IS_Id)); return Invocation_Signatures.Table (IS_Id).Locations; end Locations; ---------- -- Name -- ---------- function Name (IS_Id : Invocation_Signature_Id) return Name_Id is begin pragma Assert (Present (IS_Id)); return Invocation_Signatures.Table (IS_Id).Name; end Name; ------------- -- Present -- ------------- function Present (IC_Id : Invocation_Construct_Id) return Boolean is begin return IC_Id /= No_Invocation_Construct; end Present; ------------- -- Present -- ------------- function Present (IR_Id : Invocation_Relation_Id) return Boolean is begin return IR_Id /= No_Invocation_Relation; end Present; ------------- -- Present -- ------------- function Present (IS_Id : Invocation_Signature_Id) return Boolean is begin return IS_Id /= No_Invocation_Signature; end Present; ------------- -- Present -- ------------- function Present (Dep : Sdep_Id) return Boolean is begin return Dep /= No_Sdep_Id; end Present; ------------- -- Present -- ------------- function Present (U_Id : Unit_Id) return Boolean is begin return U_Id /= No_Unit_Id; end Present; ------------- -- Present -- ------------- function Present (W_Id : With_Id) return Boolean is begin return W_Id /= No_With_Id; end Present; -------------- -- Scan_ALI -- -------------- function Scan_ALI (F : File_Name_Type; T : Text_Buffer_Ptr; Ignore_ED : Boolean; Err : Boolean; Read_Xref : Boolean := False; Read_Lines : String := ""; Ignore_Lines : String := "X"; Ignore_Errors : Boolean := False; Directly_Scanned : 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; Ignore : array (Character range 'A' .. 'Z') of Boolean; -- Ignore (X) is set to True if lines starting with X are to -- be ignored by Scan_ALI and skipped, and False if the lines -- are to be read and processed. Bad_ALI_Format : exception; -- Exception raised by Fatal_Error if Err is True 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 procedure Check_Unknown_Line; -- If Ignore_Errors mode, then checks C to make sure that it is not -- an unknown ALI line type characters, and if so, skips lines -- until the first character of the line is one of these characters, -- at which point it does a Getc to put that character in C. The -- call has no effect if C is already an appropriate character. -- If not in Ignore_Errors mode, a fatal error is signalled if the -- line is unknown. Note that if C is an EOL on entry, the line is -- skipped (it is assumed that blank lines are never significant). -- If C is EOF on entry, the call has no effect (it is assumed that -- the caller will properly handle this case). 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. procedure Fatal_Error_Ignore; pragma Inline (Fatal_Error_Ignore); -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error function Getc return Character; -- Get next character, bumping P past the character obtained function Get_File_Name (Lower : Boolean := False; May_Be_Quoted : Boolean := False) return File_Name_Type; -- Skip blanks, then scan out a file name (name is left in Name_Buffer -- with length in Name_Len, as well as returning a File_Name_Type value. -- If May_Be_Quoted is True and the first non blank character is '"', -- then remove starting and ending quotes and undoubled internal quotes. -- If lower is false, the case is unchanged, if Lower is True then the -- result is forced to all lower case for systems where file names are -- not case sensitive. This ensures that gnatbind works correctly -- regardless of the case of the file name on all systems. The scan -- is terminated by a end of line, space or horizontal tab. Any other -- special characters are included in the returned name. function Get_Name (Ignore_Spaces : Boolean := False; Ignore_Special : Boolean := False; May_Be_Quoted : 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). -- If Lower is set to True then the Name_Buffer will be converted to -- all lower case, for systems where file names are not case sensitive. -- This ensures that gnatbind works correctly regardless of the case -- of the file name on all systems. The termination condition depends -- on the settings of Ignore_Spaces and Ignore_Special: -- -- If Ignore_Spaces is False (normal case), then scan is terminated -- by the normal end of field condition (EOL, space, horizontal tab) -- -- If Ignore_Special is False (normal case), the scan is terminated by -- a typeref bracket or an equal sign except for the special case of -- an operator name starting with a double quote that is terminated -- by another double quote. -- -- If May_Be_Quoted is True and the first non blank character is '"' -- the name is 'unquoted'. In this case Ignore_Special is ignored and -- assumed to be True. -- -- It is an error to set both Ignore_Spaces and Ignore_Special to True. -- This function handles wide characters properly. function Get_Nat return Nat; -- Skip blanks, then scan out an unsigned integer value in Nat range -- raises ALI_Reading_Error if the encoutered type is not natural. function Get_Stamp return Time_Stamp_Type; -- Skip blanks, then scan out a time stamp function Get_Unit_Name return Unit_Name_Type; -- Skip blanks, then scan out a file name (name is left in Name_Buffer -- with length in Name_Len, as well as returning a Unit_Name_Type value. -- The case is unchanged and terminated by a normal end of field. function Nextc return Character; -- Return current character without modifying pointer P procedure Get_Typeref (Current_File_Num : Sdep_Id; Ref : out Tref_Kind; File_Num : out Sdep_Id; Line : out Nat; Ref_Type : out Character; Col : out Nat; Standard_Entity : out Name_Id); -- Parse the definition of a typeref (<...>, {...} or (...)) procedure Scan_Invocation_Graph_Line; -- Parse a single line that encodes a piece of the invocation graph procedure Skip_Eol; -- Skip past spaces, then skip past end of line (fatal error if not -- at end of line). Also skips past any following blank lines. procedure Skip_Line; -- Skip rest of current line and any following blank lines procedure Skip_Space; -- Skip past white space (blanks or horizontal tab) procedure Skipc; -- Skip past next character, does not affect value in C. This call -- is like calling Getc and ignoring the returned result. --------------------- -- 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 if Ignore_Errors then while Nextc > ' ' loop P := P + 1; end loop; else Fatal_Error; end if; end if; end Check_At_End_Of_Field; ------------------------ -- Check_Unknown_Line -- ------------------------ procedure Check_Unknown_Line is begin while C not in 'A' .. 'Z' or else not Known_ALI_Lines (C) loop if C = CR or else C = LF then Skip_Line; C := Nextc; elsif C = EOF then return; elsif Ignore_Errors then Skip_Line; C := Getc; else Fatal_Error; end if; end loop; end Check_Unknown_Line; ------------ -- Checkc -- ------------ procedure Checkc (C : Character) is begin if Nextc = C then P := P + 1; elsif Ignore_Errors 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 " & -- Split the following line so that it can easily be transformed for -- other back-ends where the compiler might have a different name. "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; ------------------------ -- Fatal_Error_Ignore -- ------------------------ procedure Fatal_Error_Ignore is begin if not Ignore_Errors then Fatal_Error; end if; end Fatal_Error_Ignore; ------------------- -- Get_File_Name -- ------------------- function Get_File_Name (Lower : Boolean := False; May_Be_Quoted : Boolean := False) return File_Name_Type is F : Name_Id; begin F := Get_Name (Ignore_Special => True, May_Be_Quoted => May_Be_Quoted); -- 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)); return Name_Find; else return File_Name_Type (F); end if; end Get_File_Name; -------------- -- Get_Name -- -------------- function Get_Name (Ignore_Spaces : Boolean := False; Ignore_Special : Boolean := False; May_Be_Quoted : Boolean := False) return Name_Id is Char : Character; begin Name_Len := 0; Skip_Space; if At_Eol then if Ignore_Errors then return Error_Name; else Fatal_Error; end if; end if; Char := Getc; -- Deal with quoted characters if May_Be_Quoted and then Char = '"' then loop if At_Eol then if Ignore_Errors then return Error_Name; else Fatal_Error; end if; end if; Char := Getc; if Char = '"' then if At_Eol then exit; else Char := Getc; if Char /= '"' then P := P - 1; exit; end if; end if; end if; Add_Char_To_Name_Buffer (Char); end loop; -- Other than case of quoted character else P := P - 1; loop Add_Char_To_Name_Buffer (Getc); exit when At_End_Of_Field and then not Ignore_Spaces; if not Ignore_Special then if Name_Buffer (1) = '"' then exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"'; else -- Terminate on parens or angle brackets or equal sign exit when Nextc = '(' or else Nextc = ')' or else Nextc = '{' or else Nextc = '}' or else Nextc = '<' or else Nextc = '>' or else Nextc = '='; -- Terminate on comma exit when Nextc = ','; -- Terminate if left bracket not part of wide char -- sequence Note that we only recognize brackets -- notation so far ??? exit when Nextc = '[' and then T (P + 1) /= '"'; -- Terminate if right bracket not part of wide char -- sequence. exit when Nextc = ']' and then T (P - 1) /= '"'; end if; end if; end loop; end if; return Name_Find; end Get_Name; ------------------- -- Get_Unit_Name -- ------------------- function Get_Unit_Name return Unit_Name_Type is begin return Unit_Name_Type (Get_Name); end Get_Unit_Name; ------------- -- Get_Nat -- ------------- function Get_Nat return Nat is V : Nat; begin Skip_Space; -- Check if we are on a number. In the case of bad ALI files, this -- may not be true. if not (Nextc in '0' .. '9') then Fatal_Error; end if; V := 0; loop V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0')); exit when At_End_Of_Field; exit when Nextc < '0' or else 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 if Ignore_Errors then return Dummy_Time_Stamp; else Fatal_Error; end if; 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; ----------------- -- Get_Typeref -- ----------------- procedure Get_Typeref (Current_File_Num : Sdep_Id; Ref : out Tref_Kind; File_Num : out Sdep_Id; Line : out Nat; Ref_Type : out Character; Col : out Nat; Standard_Entity : out Name_Id) is N : Nat; begin case Nextc is when '<' => Ref := Tref_Derived; when '(' => Ref := Tref_Access; when '{' => Ref := Tref_Type; when others => Ref := Tref_None; end case; -- Case of typeref field present if Ref /= Tref_None then P := P + 1; -- skip opening bracket if Nextc in 'a' .. 'z' then File_Num := No_Sdep_Id; Line := 0; Ref_Type := ' '; Col := 0; Standard_Entity := Get_Name (Ignore_Spaces => True); else N := Get_Nat; if Nextc = '|' then File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1); P := P + 1; N := Get_Nat; else File_Num := Current_File_Num; end if; Line := N; Ref_Type := Getc; Col := Get_Nat; Standard_Entity := No_Name; end if; -- ??? Temporary workaround for nested generics case: -- 4i4 Directories{1|4I9[4|6[3|3]]} -- See C918-002 declare Nested_Brackets : Natural := 0; begin loop case Nextc is when '[' => Nested_Brackets := Nested_Brackets + 1; when ']' => Nested_Brackets := Nested_Brackets - 1; when others => if Nested_Brackets = 0 then exit; end if; end case; Skipc; end loop; end; P := P + 1; -- skip closing bracket Skip_Space; -- No typeref entry present else File_Num := No_Sdep_Id; Line := 0; Ref_Type := ' '; Col := 0; Standard_Entity := No_Name; end if; end Get_Typeref; ---------- -- 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; -------------------------------- -- Scan_Invocation_Graph_Line -- -------------------------------- procedure Scan_Invocation_Graph_Line is procedure Scan_Invocation_Construct_Line; pragma Inline (Scan_Invocation_Construct_Line); -- Parse an invocation construct line and construct the corresponding -- construct. The following data structures are updated: -- -- * Invocation_Constructs -- * Units procedure Scan_Invocation_Graph_Attributes_Line; pragma Inline (Scan_Invocation_Graph_Attributes_Line); -- Parse an invocation-graph attributes line. The following data -- structures are updated: -- -- * Units procedure Scan_Invocation_Relation_Line; pragma Inline (Scan_Invocation_Relation_Line); -- Parse an invocation relation line and construct the corresponding -- relation. The following data structures are updated: -- -- * Invocation_Relations -- * Units function Scan_Invocation_Signature return Invocation_Signature_Id; pragma Inline (Scan_Invocation_Signature); -- Parse a single invocation signature while populating the following -- data structures: -- -- * Invocation_Signatures -- * Sig_To_Sig_Map ------------------------------------ -- Scan_Invocation_Construct_Line -- ------------------------------------ procedure Scan_Invocation_Construct_Line is Body_Placement : Declaration_Placement_Kind; Kind : Invocation_Construct_Kind; Signature : Invocation_Signature_Id; Spec_Placement : Declaration_Placement_Kind; begin -- construct-kind Kind := Code_To_Invocation_Construct_Kind (Getc); Checkc (' '); Skip_Space; -- construct-spec-placement Spec_Placement := Code_To_Declaration_Placement_Kind (Getc); Checkc (' '); Skip_Space; -- construct-body-placement Body_Placement := Code_To_Declaration_Placement_Kind (Getc); Checkc (' '); Skip_Space; -- construct-signature Signature := Scan_Invocation_Signature; Skip_Eol; Add_Invocation_Construct (Body_Placement => Body_Placement, Kind => Kind, Signature => Signature, Spec_Placement => Spec_Placement); end Scan_Invocation_Construct_Line; ------------------------------------------- -- Scan_Invocation_Graph_Attributes_Line -- ------------------------------------------- procedure Scan_Invocation_Graph_Attributes_Line is begin -- encoding-kind Set_Invocation_Graph_Encoding (Code_To_Invocation_Graph_Encoding_Kind (Getc)); Skip_Eol; end Scan_Invocation_Graph_Attributes_Line; ----------------------------------- -- Scan_Invocation_Relation_Line -- ----------------------------------- procedure Scan_Invocation_Relation_Line is Extra : Name_Id; Invoker : Invocation_Signature_Id; Kind : Invocation_Kind; Target : Invocation_Signature_Id; begin -- relation-kind Kind := Code_To_Invocation_Kind (Getc); Checkc (' '); Skip_Space; -- (extra-name | "none") Extra := Get_Name; if Extra = Name_None then Extra := No_Name; end if; Checkc (' '); Skip_Space; -- invoker-signature Invoker := Scan_Invocation_Signature; Checkc (' '); Skip_Space; -- target-signature Target := Scan_Invocation_Signature; Skip_Eol; Add_Invocation_Relation (Extra => Extra, Invoker => Invoker, Kind => Kind, Target => Target); end Scan_Invocation_Relation_Line; ------------------------------- -- Scan_Invocation_Signature -- ------------------------------- function Scan_Invocation_Signature return Invocation_Signature_Id is Column : Nat; Line : Nat; Locations : Name_Id; Name : Name_Id; Scope : Name_Id; begin -- [ Checkc ('['); -- name Name := Get_Name; Checkc (' '); Skip_Space; -- scope Scope := Get_Name; Checkc (' '); Skip_Space; -- line Line := Get_Nat; Checkc (' '); Skip_Space; -- column Column := Get_Nat; Checkc (' '); Skip_Space; -- (locations | "none") Locations := Get_Name; if Locations = Name_None then Locations := No_Name; end if; -- ] Checkc (']'); -- Create an invocation signature from the scanned attributes return Invocation_Signature_Of (Column => Column, Line => Line, Locations => Locations, Name => Name, Scope => Scope); end Scan_Invocation_Signature; -- Local variables Line : Invocation_Graph_Line_Kind; -- Start of processing for Scan_Invocation_Graph_Line begin if Ignore ('G') then return; end if; Checkc (' '); Skip_Space; -- line-kind Line := Code_To_Invocation_Graph_Line_Kind (Getc); Checkc (' '); Skip_Space; -- line-attributes case Line is when Invocation_Construct_Line => Scan_Invocation_Construct_Line; when Invocation_Graph_Attributes_Line => Scan_Invocation_Graph_Attributes_Line; when Invocation_Relation_Line => Scan_Invocation_Relation_Line; end case; end Scan_Invocation_Graph_Line; -------------- -- Skip_Eol -- -------------- procedure Skip_Eol is begin Skip_Space; if not At_Eol then if Ignore_Errors then while not At_Eol loop P := P + 1; end loop; else Fatal_Error; end if; 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_Line -- --------------- procedure Skip_Line is begin while not At_Eol loop P := P + 1; end loop; Skip_Eol; end Skip_Line; ---------------- -- Skip_Space -- ---------------- procedure Skip_Space is begin while Nextc = ' ' or else Nextc = HT loop P := P + 1; end loop; end Skip_Space; ----------- -- Skipc -- ----------- procedure Skipc is begin if P /= T'Last then P := P + 1; end if; end Skipc; -- Start of processing for Scan_ALI begin First_Sdep_Entry := Sdep.Last + 1; -- Acquire lines to be ignored if Read_Xref then Ignore := ('T' | 'U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); -- Read_Lines parameter given elsif Read_Lines /= "" then Ignore := ('U' => False, others => True); for J in Read_Lines'Range loop Ignore (Read_Lines (J)) := False; end loop; -- Process Ignore_Lines parameter else Ignore := (others => False); for J in Ignore_Lines'Range loop pragma Assert (Ignore_Lines (J) /= 'U'); Ignore (Ignore_Lines (J)) := True; end loop; end if; -- Setup ALI Table entry with appropriate defaults ALIs.Increment_Last; Id := ALIs.Last; Set_Name_Table_Int (F, Int (Id)); ALIs.Table (Id) := ( Afile => F, Compile_Errors => False, First_Interrupt_State => Interrupt_States.Last + 1, First_Sdep => No_Sdep_Id, First_Specific_Dispatching => Specific_Dispatching.Last + 1, First_Unit => No_Unit_Id, GNATprove_Mode => False, Invocation_Graph_Encoding => No_Encoding, Last_Interrupt_State => Interrupt_States.Last, Last_Sdep => No_Sdep_Id, Last_Specific_Dispatching => Specific_Dispatching.Last, Last_Unit => No_Unit_Id, Locking_Policy => ' ', Main_Priority => -1, Main_CPU => -1, Main_Program => None, No_Component_Reordering => False, No_Object => False, Normalize_Scalars => False, Ofile_Full_Name => Full_Object_File_Name, Partition_Elaboration_Policy => ' ', Queuing_Policy => ' ', Restrictions => No_Restrictions, SAL_Interface => False, Sfile => No_File, SSO_Default => ' ', Task_Dispatching_Policy => ' ', Time_Slice_Value => -1, WC_Encoding => 'b', Unit_Exception_Table => False, Ver => (others => ' '), Ver_Len => 0, Frontend_Exceptions => False, Zero_Cost_Exceptions => False); -- Now we acquire the input lines from the ALI file. Note that the -- convention in the following code is that as we enter each section, -- C is set to contain the first character of the following line. C := Getc; Check_Unknown_Line; -- Acquire library version if C /= 'V' then -- The V line missing really indicates trouble, most likely it -- means we don't have an ALI file at all, so here we give a -- fatal error even if we are in Ignore_Errors mode. Fatal_Error; elsif Ignore ('V') then Skip_Line; else 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; end if; C := Getc; Check_Unknown_Line; -- Acquire main program line if present if C = 'M' then if Ignore ('M') then Skip_Line; else 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; if Nextc = 'C' then P := P + 1; Checkc ('='); ALIs.Table (Id).Main_CPU := Get_Nat; end if; Skip_Space; Checkc ('W'); Checkc ('='); ALIs.Table (Id).WC_Encoding := Getc; end if; Skip_Eol; end if; C := Getc; end if; -- Acquire argument lines First_Arg := Args.Last + 1; A_Loop : loop Check_Unknown_Line; exit A_Loop when C /= 'A'; if Ignore ('A') then Skip_Line; else Checkc (' '); -- Scan out argument Name_Len := 0; while not At_Eol loop Add_Char_To_Name_Buffer (Getc); end loop; -- If -fstack-check, record that it occurred. Note that an -- additional string parameter can be specified, in the form of -- -fstack-check={no|generic|specific}. "no" means no checking, -- "generic" means force the use of old-style checking, and -- "specific" means use the best checking method. if Name_Len >= 13 and then Name_Buffer (1 .. 13) = "-fstack-check" and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no" then Stack_Check_Switch_Set := True; end if; -- Store the argument Args.Increment_Last; Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); Skip_Eol; end if; C := Getc; end loop A_Loop; -- Acquire P line Check_Unknown_Line; while C /= 'P' loop if Ignore_Errors then if C = EOF then Fatal_Error; else Skip_Line; C := Nextc; end if; else Fatal_Error; end if; end loop; if Ignore ('P') then Skip_Line; -- Process P line else NS_Found := False; while not At_Eol loop Checkc (' '); Skip_Space; C := Getc; -- Processing for CE if C = 'C' then Checkc ('E'); ALIs.Table (Id).Compile_Errors := True; -- Processing for DB elsif C = 'D' then Checkc ('B'); Detect_Blocking := True; -- Processing for Ex elsif C = 'E' then Partition_Elaboration_Policy_Specified := Getc; ALIs.Table (Id).Partition_Elaboration_Policy := Partition_Elaboration_Policy_Specified; -- Processing for FX elsif C = 'F' then C := Getc; if C = 'X' then ALIs.Table (Id).Frontend_Exceptions := True; Frontend_Exceptions_Specified := True; else Fatal_Error_Ignore; end if; -- Processing for GP elsif C = 'G' then Checkc ('P'); GNATprove_Mode_Specified := True; ALIs.Table (Id).GNATprove_Mode := True; -- Processing for Lx elsif C = 'L' then Locking_Policy_Specified := Getc; ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified; -- Processing for flags starting with N elsif C = 'N' then C := Getc; -- Processing for NC if C = 'C' then ALIs.Table (Id).No_Component_Reordering := True; No_Component_Reordering_Specified := True; -- Processing for NO elsif C = 'O' then ALIs.Table (Id).No_Object := True; No_Object_Specified := True; -- Processing for NR elsif C = 'R' then No_Run_Time_Mode := True; Configurable_Run_Time_Mode := True; -- Processing for NS elsif C = 'S' then ALIs.Table (Id).Normalize_Scalars := True; Normalize_Scalars_Specified := True; NS_Found := True; -- Invalid switch starting with N else Fatal_Error_Ignore; end if; -- Processing for OH/OL elsif C = 'O' then C := Getc; if C = 'L' or else C = 'H' then ALIs.Table (Id).SSO_Default := C; SSO_Default_Specified := True; else Fatal_Error_Ignore; end if; -- Processing for Qx elsif C = 'Q' then Queuing_Policy_Specified := Getc; ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; -- Processing for flags starting with S elsif C = 'S' then C := Getc; -- Processing for SL if C = 'L' then ALIs.Table (Id).SAL_Interface := True; -- Processing for SS elsif C = 'S' then Opt.Sec_Stack_Used := True; -- Invalid switch starting with S else Fatal_Error_Ignore; end if; -- Processing for Tx elsif C = 'T' then Task_Dispatching_Policy_Specified := Getc; ALIs.Table (Id).Task_Dispatching_Policy := Task_Dispatching_Policy_Specified; -- Processing for switch starting with U elsif C = 'U' then C := Getc; -- Processing for UA if C = 'A' then Unreserve_All_Interrupts_Specified := True; -- Processing for UX elsif C = 'X' then ALIs.Table (Id).Unit_Exception_Table := True; -- Invalid switches starting with U else Fatal_Error_Ignore; end if; -- Processing for ZX elsif C = 'Z' then C := Getc; if C = 'X' then ALIs.Table (Id).Zero_Cost_Exceptions := True; Zero_Cost_Exceptions_Specified := True; else Fatal_Error_Ignore; end if; -- Invalid parameter else C := Getc; Fatal_Error_Ignore; end if; end loop; if not NS_Found then No_Normalize_Scalars_Specified := True; end if; Skip_Eol; end if; C := Getc; Check_Unknown_Line; -- Loop to skip to first restrictions line while C /= 'R' loop if Ignore_Errors then if C = EOF then Fatal_Error; else Skip_Line; C := Nextc; end if; else Fatal_Error; end if; end loop; -- Ignore all 'R' lines if that is required if Ignore ('R') then while C = 'R' loop Skip_Line; C := Getc; end loop; -- Here we process the restrictions lines (other than unit name cases) else Scan_Restrictions : declare Save_R : constant Restrictions_Info := Cumulative_Restrictions; -- Save cumulative restrictions in case we have a fatal error Bad_R_Line : exception; -- Signal bad restrictions line (raised on unexpected character) Typ : Character; R : Restriction_Id; N : Natural; begin -- Named restriction case if Nextc = 'N' then Skip_Line; C := Getc; -- Loop through RR and RV lines while C = 'R' and then Nextc /= ' ' loop Typ := Getc; Checkc (' '); -- Acquire restriction name Name_Len := 0; while not At_Eol and then Nextc /= '=' loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; end loop; -- Now search list of restrictions to find match declare RN : String renames Name_Buffer (1 .. Name_Len); begin R := Restriction_Id'First; while R /= Not_A_Restriction_Id loop if Restriction_Id'Image (R) = RN then goto R_Found; end if; R := Restriction_Id'Succ (R); end loop; -- We don't recognize the restriction. This might be -- thought of as an error, and it really is, but we -- want to allow building with inconsistent versions -- of the binder and ali files (see comments at the -- start of package System.Rident), so we just ignore -- this situation. goto Done_With_Restriction_Line; end; <<R_Found>> case R is -- Boolean restriction case when All_Boolean_Restrictions => case Typ is when 'V' => ALIs.Table (Id).Restrictions.Violated (R) := True; Cumulative_Restrictions.Violated (R) := True; when 'R' => ALIs.Table (Id).Restrictions.Set (R) := True; Cumulative_Restrictions.Set (R) := True; when others => raise Bad_R_Line; end case; -- Parameter restriction case when All_Parameter_Restrictions => if At_Eol or else Nextc /= '=' then raise Bad_R_Line; else Skipc; end if; N := Natural (Get_Nat); case Typ is -- Restriction set when 'R' => ALIs.Table (Id).Restrictions.Set (R) := True; ALIs.Table (Id).Restrictions.Value (R) := N; if Cumulative_Restrictions.Set (R) then Cumulative_Restrictions.Value (R) := Integer'Min (Cumulative_Restrictions.Value (R), N); else Cumulative_Restrictions.Set (R) := True; Cumulative_Restrictions.Value (R) := N; end if; -- Restriction violated when 'V' => ALIs.Table (Id).Restrictions.Violated (R) := True; Cumulative_Restrictions.Violated (R) := True; ALIs.Table (Id).Restrictions.Count (R) := N; -- Checked Max_Parameter case if R in Checked_Max_Parameter_Restrictions then Cumulative_Restrictions.Count (R) := Integer'Max (Cumulative_Restrictions.Count (R), N); -- Other checked parameter cases else declare pragma Unsuppress (Overflow_Check); begin Cumulative_Restrictions.Count (R) := Cumulative_Restrictions.Count (R) + N; exception when Constraint_Error => -- A constraint error comes from the -- addition. We reset to the maximum -- and indicate that the real value -- is now unknown. Cumulative_Restrictions.Value (R) := Integer'Last; Cumulative_Restrictions.Unknown (R) := True; end; end if; -- Deal with + case if Nextc = '+' then Skipc; ALIs.Table (Id).Restrictions.Unknown (R) := True; Cumulative_Restrictions.Unknown (R) := True; end if; -- Other than 'R' or 'V' when others => raise Bad_R_Line; end case; if not At_Eol then raise Bad_R_Line; end if; -- Bizarre error case NOT_A_RESTRICTION when Not_A_Restriction_Id => raise Bad_R_Line; end case; if not At_Eol then raise Bad_R_Line; end if; <<Done_With_Restriction_Line>> Skip_Line; C := Getc; end loop; -- Positional restriction case else Checkc (' '); Skip_Space; -- Acquire information for boolean restrictions for R in All_Boolean_Restrictions loop C := Getc; case C is when 'v' => ALIs.Table (Id).Restrictions.Violated (R) := True; Cumulative_Restrictions.Violated (R) := True; when 'r' => ALIs.Table (Id).Restrictions.Set (R) := True; Cumulative_Restrictions.Set (R) := True; when 'n' => null; when others => raise Bad_R_Line; end case; end loop; -- Acquire information for parameter restrictions for RP in All_Parameter_Restrictions loop case Getc is when 'n' => null; when 'r' => ALIs.Table (Id).Restrictions.Set (RP) := True; declare N : constant Integer := Integer (Get_Nat); begin ALIs.Table (Id).Restrictions.Value (RP) := N; if Cumulative_Restrictions.Set (RP) then Cumulative_Restrictions.Value (RP) := Integer'Min (Cumulative_Restrictions.Value (RP), N); else Cumulative_Restrictions.Set (RP) := True; Cumulative_Restrictions.Value (RP) := N; end if; end; when others => raise Bad_R_Line; end case; -- Acquire restrictions violations information case Getc is when 'n' => null; when 'v' => ALIs.Table (Id).Restrictions.Violated (RP) := True; Cumulative_Restrictions.Violated (RP) := True; declare N : constant Integer := Integer (Get_Nat); begin ALIs.Table (Id).Restrictions.Count (RP) := N; if RP in Checked_Max_Parameter_Restrictions then Cumulative_Restrictions.Count (RP) := Integer'Max (Cumulative_Restrictions.Count (RP), N); else declare pragma Unsuppress (Overflow_Check); begin Cumulative_Restrictions.Count (RP) := Cumulative_Restrictions.Count (RP) + N; exception when Constraint_Error => -- A constraint error comes from the add. We -- reset to the maximum and indicate that the -- real value is now unknown. Cumulative_Restrictions.Value (RP) := Integer'Last; Cumulative_Restrictions.Unknown (RP) := True; end; end if; if Nextc = '+' then Skipc; ALIs.Table (Id).Restrictions.Unknown (RP) := True; Cumulative_Restrictions.Unknown (RP) := True; end if; end; when others => raise Bad_R_Line; end case; end loop; if not At_Eol then raise Bad_R_Line; else Skip_Line; C := Getc; end if; end if; -- Here if error during scanning of restrictions line exception when Bad_R_Line => -- In Ignore_Errors mode, undo any changes to restrictions -- from this unit, and continue on, skipping remaining R -- lines for this unit. if Ignore_Errors then Cumulative_Restrictions := Save_R; ALIs.Table (Id).Restrictions := No_Restrictions; loop Skip_Eol; C := Getc; exit when C /= 'R'; end loop; -- In normal mode, this is a fatal error else Fatal_Error; end if; end Scan_Restrictions; end if; -- Acquire additional restrictions (No_Dependence) lines if present while C = 'R' loop if Ignore ('R') then Skip_Line; else Skip_Space; No_Deps.Append ((Id, Get_Name)); Skip_Eol; end if; C := Getc; end loop; -- Acquire 'I' lines if present Check_Unknown_Line; while C = 'I' loop if Ignore ('I') then Skip_Line; else declare Int_Num : Nat; I_State : Character; Line_No : Nat; begin Int_Num := Get_Nat; Skip_Space; I_State := Getc; Line_No := Get_Nat; Interrupt_States.Append ( (Interrupt_Id => Int_Num, Interrupt_State => I_State, IS_Pragma_Line => Line_No)); ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last; Skip_Eol; end; end if; C := Getc; end loop; -- Acquire 'S' lines if present Check_Unknown_Line; while C = 'S' loop if Ignore ('S') then Skip_Line; else declare Policy : Character; First_Prio : Nat; Last_Prio : Nat; Line_No : Nat; begin Checkc (' '); Skip_Space; Policy := Getc; Skip_Space; First_Prio := Get_Nat; Last_Prio := Get_Nat; Line_No := Get_Nat; Specific_Dispatching.Append ( (Dispatching_Policy => Policy, First_Priority => First_Prio, Last_Priority => Last_Prio, PSD_Pragma_Line => Line_No)); ALIs.Table (Id).Last_Specific_Dispatching := Specific_Dispatching.Last; Skip_Eol; end; end if; C := Getc; end loop; -- Loop to acquire unit entries U_Loop : loop Check_Unknown_Line; exit U_Loop when C /= 'U'; -- Note: as per spec, we never ignore U lines 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; declare UL : Unit_Record renames Units.Table (Units.Last); begin UL.Uname := Get_Unit_Name; UL.Predefined := Is_Predefined_Unit; UL.Internal := Is_Internal_Unit; UL.My_ALI := Id; UL.Sfile := Get_File_Name (Lower => True); UL.Pure := False; UL.Preelab := False; UL.No_Elab := False; UL.Shared_Passive := False; UL.RCI := False; UL.Remote_Types := False; UL.Serious_Errors := False; UL.Has_RACW := False; UL.Init_Scalars := False; UL.Is_Generic := False; UL.Icasing := Mixed_Case; UL.Kcasing := All_Lower_Case; UL.Dynamic_Elab := False; UL.Elaborate_Body := False; UL.Set_Elab_Entity := False; UL.Version := "00000000"; UL.First_With := Withs.Last + 1; UL.First_Arg := First_Arg; UL.First_Invocation_Construct := Invocation_Constructs.Last + 1; UL.Last_Invocation_Construct := No_Invocation_Construct; UL.First_Invocation_Relation := Invocation_Relations.Last + 1; UL.Last_Invocation_Relation := No_Invocation_Relation; UL.Elab_Position := 0; UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; UL.Directly_Scanned := Directly_Scanned; UL.Body_Needed_For_SAL := False; UL.Elaborate_Body_Desirable := False; UL.Optimize_Alignment := 'O'; UL.Has_Finalizer := False; UL.Primary_Stack_Count := 0; UL.Sec_Stack_Count := 0; if Debug_Flag_U then Write_Str (" ----> reading unit "); Write_Int (Int (Units.Last)); Write_Str (" "); Write_Unit_Name (UL.Uname); Write_Str (" from file "); Write_Name (UL.Sfile); Write_Eol; end if; end; -- Check for duplicated unit in different files declare Info : constant Int := Get_Name_Table_Int (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 ignore duplicate unit name. This is the -- case of a call from gnatmake, where the situation can arise -- from substitution of source files. In such situations, the -- processing in gnatmake will always result in any required -- recompilations in any case, and if we consider this to be -- an error we get strange cases (for example when a generic -- instantiation is replaced by a normal package) where we -- read the old ali file, decide to recompile, and then decide -- that the old and new ali files are incompatible. if Err then null; -- If Err is not set, then this is a fatal error. This is -- the case of being called from the binder, where we must -- definitely diagnose this as an 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_Int (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; -- BD/BN parameters elsif C = 'B' then C := Getc; if C = 'D' then Check_At_End_Of_Field; Units.Table (Units.Last).Elaborate_Body_Desirable := True; elsif C = 'N' then Check_At_End_Of_Field; Units.Table (Units.Last).Body_Needed_For_SAL := True; else Fatal_Error_Ignore; end if; -- DE parameter (Dynamic elaboration checks) elsif C = 'D' then C := Getc; if C = 'E' then Check_At_End_Of_Field; Units.Table (Units.Last).Dynamic_Elab := True; Dynamic_Elaboration_Checks_Specified := True; else Fatal_Error_Ignore; end if; -- 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_Ignore; end if; Check_At_End_Of_Field; -- GE parameter (generic) elsif C = 'G' then C := Getc; if C = 'E' then Check_At_End_Of_Field; Units.Table (Units.Last).Is_Generic := True; else Fatal_Error_Ignore; end if; -- 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_Ignore; 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_Ignore; end if; Check_At_End_Of_Field; -- NE parameter elsif C = 'N' then C := Getc; if C = 'E' then Units.Table (Units.Last).No_Elab := True; Check_At_End_Of_Field; else Fatal_Error_Ignore; end if; -- PF/PR/PU/PK parameters elsif C = 'P' then C := Getc; if C = 'F' then Units.Table (Units.Last).Has_Finalizer := True; elsif C = 'R' then Units.Table (Units.Last).Preelab := True; elsif C = 'U' then Units.Table (Units.Last).Pure := True; elsif C = 'K' then Units.Table (Units.Last).Unit_Kind := 'p'; else Fatal_Error_Ignore; end if; Check_At_End_Of_Field; -- OL/OO/OS/OT parameters elsif C = 'O' then C := Getc; if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then Units.Table (Units.Last).Optimize_Alignment := C; else Fatal_Error_Ignore; end if; Check_At_End_Of_Field; -- RC/RT parameters elsif C = 'R' then C := Getc; if C = 'C' then Units.Table (Units.Last).RCI := True; elsif C = 'T' then Units.Table (Units.Last).Remote_Types := True; elsif C = 'A' then Units.Table (Units.Last).Has_RACW := True; else Fatal_Error_Ignore; end if; Check_At_End_Of_Field; -- SE/SP/SU parameters elsif C = 'S' then C := Getc; if C = 'E' then Units.Table (Units.Last).Serious_Errors := True; elsif C = 'P' then Units.Table (Units.Last).Shared_Passive := True; elsif C = 'U' then Units.Table (Units.Last).Unit_Kind := 's'; else Fatal_Error_Ignore; end if; Check_At_End_Of_Field; else C := Getc; Fatal_Error_Ignore; end if; end loop; Skip_Eol; C := Getc; -- Scan out With lines for this unit With_Loop : loop Check_Unknown_Line; exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z'; if Ignore ('W') then Skip_Line; else Checkc (' '); Skip_Space; Withs.Increment_Last; Withs.Table (Withs.Last).Uname := Get_Unit_Name; Withs.Table (Withs.Last).Elaborate := False; Withs.Table (Withs.Last).Elaborate_All := False; Withs.Table (Withs.Last).Elab_Desirable := False; Withs.Table (Withs.Last).Elab_All_Desirable := False; Withs.Table (Withs.Last).SAL_Interface := False; Withs.Table (Withs.Last).Limited_With := (C = 'Y'); Withs.Table (Withs.Last).Implicit_With := (C = 'Z'); -- 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_File_Name (Lower => True); Withs.Table (Withs.Last).Afile := Get_File_Name (Lower => True); -- Scan out possible E, EA, ED, and AD parameters while not At_Eol loop Skip_Space; if Nextc = 'A' then P := P + 1; Checkc ('D'); Check_At_End_Of_Field; -- Store AD indication unless ignore required if not Ignore_ED then Withs.Table (Withs.Last).Elab_All_Desirable := True; end if; elsif 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_Desirable := True; end if; end if; else Fatal_Error; end if; end loop; end if; Skip_Eol; end if; C := Getc; end loop With_Loop; Units.Table (Units.Last).Last_With := Withs.Last; Units.Table (Units.Last).Last_Arg := Args.Last; -- Scan out task stack information for the unit if present Check_Unknown_Line; if C = 'T' then if Ignore ('T') then Skip_Line; else Checkc (' '); Skip_Space; Units.Table (Units.Last).Primary_Stack_Count := Get_Nat; Skip_Space; Units.Table (Units.Last).Sec_Stack_Count := Get_Nat; Skip_Space; Skip_Eol; end if; C := Getc; end if; -- If there are linker options lines present, scan them Name_Len := 0; Linker_Options_Loop : loop Check_Unknown_Line; exit Linker_Options_Loop when C /= 'L'; if Ignore ('L') then Skip_Line; else Checkc (' '); Skip_Space; Checkc ('"'); loop C := Getc; if C < Character'Val (16#20#) or else C > Character'Val (16#7E#) then Fatal_Error_Ignore; 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_Ignore; 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; end if; C := Getc; end loop Linker_Options_Loop; -- Store the linker options entry if one was found if Name_Len /= 0 then Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last).Name := Name_Enter; Linker_Options.Table (Linker_Options.Last).Unit := Units.Last; Linker_Options.Table (Linker_Options.Last).Internal_File := Is_Internal_File_Name (F); end if; -- If there are notes present, scan them Notes_Loop : loop Check_Unknown_Line; exit Notes_Loop when C /= 'N'; if Ignore ('N') then Skip_Line; else Checkc (' '); Notes.Increment_Last; Notes.Table (Notes.Last).Pragma_Type := Getc; Notes.Table (Notes.Last).Pragma_Line := Get_Nat; Checkc (':'); Notes.Table (Notes.Last).Pragma_Col := Get_Nat; if not At_Eol and then Nextc = ':' then Checkc (':'); Notes.Table (Notes.Last).Pragma_Source_File := Get_File_Name (Lower => True); else Notes.Table (Notes.Last).Pragma_Source_File := Units.Table (Units.Last).Sfile; end if; if At_Eol then Notes.Table (Notes.Last).Pragma_Args := No_Name; else -- Note: can't use Get_Name here as the remainder of the -- line is unstructured text whose syntax depends on the -- particular pragma used. Checkc (' '); Name_Len := 0; while not At_Eol loop Add_Char_To_Name_Buffer (Getc); end loop; end if; Skip_Eol; end if; C := Getc; end loop Notes_Loop; end loop U_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; -- Scan out external version references and put in hash table E_Loop : loop Check_Unknown_Line; exit E_Loop when C /= 'E'; if Ignore ('E') then Skip_Line; else 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; end if; C := Getc; end loop E_Loop; -- Scan out source dependency lines for this ALI file ALIs.Table (Id).First_Sdep := Sdep.Last + 1; D_Loop : loop Check_Unknown_Line; exit D_Loop when C /= 'D'; if Ignore ('D') then Skip_Line; else Checkc (' '); Skip_Space; Sdep.Increment_Last; -- In the following call, Lower is not set to True, this is either -- a bug, or it deserves a special comment as to why this is so??? -- The file/path name may be quoted Sdep.Table (Sdep.Last).Sfile := Get_File_Name (May_Be_Quoted => 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 (sub)unit and reference file name entries Sdep.Table (Sdep.Last).Subunit_Name := No_Name; Sdep.Table (Sdep.Last).Unit_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 (sub)unit name if Nextc not in '0' .. '9' then Name_Len := 0; while not At_End_Of_Field loop Add_Char_To_Name_Buffer (Getc); end loop; -- Set the (sub)unit name. Note that we use Name_Find rather -- than Name_Enter here as the subunit name may already -- have been put in the name table by the Project Manager. if Name_Len <= 2 or else Name_Buffer (Name_Len - 1) /= '%' then Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; else Name_Len := Name_Len - 2; Sdep.Table (Sdep.Last).Unit_Name := Name_Find; end if; 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 Add_Char_To_Name_Buffer (Getc); end loop; Sdep.Table (Sdep.Last).Rfile := Name_Enter; end if; end if; Skip_Eol; end if; C := Getc; end loop D_Loop; ALIs.Table (Id).Last_Sdep := Sdep.Last; -- Loop through invocation-graph lines G_Loop : loop Check_Unknown_Line; exit G_Loop when C /= 'G'; Scan_Invocation_Graph_Line; C := Getc; end loop G_Loop; -- We must at this stage be at an Xref line or the end of file if C = EOF then return Id; end if; Check_Unknown_Line; if C /= 'X' then Fatal_Error; end if; -- If we are ignoring Xref sections we are done (we ignore all -- remaining lines since only xref related lines follow X). if Ignore ('X') and then not Debug_Flag_X then return Id; end if; -- Loop through Xref sections X_Loop : loop Check_Unknown_Line; exit X_Loop when C /= 'X'; -- 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_File_Name; XS.First_Entity := Xref_Entity.Last + 1; Current_File_Num := XS.File_Num; Skip_Space; 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 Local_File_Num : Sdep_Id := Current_File_Num; 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); Local_File_Num := XR.File_Num; P := P + 1; N := Get_Nat; else XR.File_Num := Local_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; case Getc is when '*' => XE.Visibility := Global; when '+' => XE.Visibility := Static; when others => XE.Visibility := Other; end case; XE.Entity := Get_Name; -- Handle the information about generic instantiations if Nextc = '[' then Skipc; -- Opening '[' N := Get_Nat; if Nextc /= '|' then XE.Iref_File_Num := Current_File_Num; XE.Iref_Line := N; else XE.Iref_File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1); Skipc; XE.Iref_Line := Get_Nat; end if; if Getc /= ']' then Fatal_Error; end if; else XE.Iref_File_Num := No_Sdep_Id; XE.Iref_Line := 0; end if; Current_File_Num := XS.File_Num; -- 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; XE.Oref_File_Num := No_Sdep_Id; XE.Tref_File_Num := No_Sdep_Id; XE.Tref := Tref_None; XE.First_Xref := Xref.Last + 1; -- Loop to check for additional info present loop declare Ref : Tref_Kind; File : Sdep_Id; Line : Nat; Typ : Character; Col : Nat; Std : Name_Id; begin Get_Typeref (Current_File_Num, Ref, File, Line, Typ, Col, Std); exit when Ref = Tref_None; -- Do we have an overriding procedure? if Ref = Tref_Derived and then Typ = 'p' then XE.Oref_File_Num := File; XE.Oref_Line := Line; XE.Oref_Col := Col; -- Arrays never override anything, and <> points to -- the index types instead elsif Ref = Tref_Derived and then XE.Etype = 'A' then -- Index types are stored in the list of references Xref.Increment_Last; declare XR : Xref_Record renames Xref.Table (Xref.Last); begin XR.File_Num := File; XR.Line := Line; XR.Rtype := Array_Index_Reference; XR.Col := Col; XR.Name := Std; end; -- Interfaces are stored in the list of references, -- although the parent type itself is stored in XE. -- The first interface (when there are only -- interfaces) is stored in XE.Tref*) elsif Ref = Tref_Derived and then Typ = 'R' and then XE.Tref_File_Num /= No_Sdep_Id then Xref.Increment_Last; declare XR : Xref_Record renames Xref.Table (Xref.Last); begin XR.File_Num := File; XR.Line := Line; XR.Rtype := Interface_Reference; XR.Col := Col; XR.Name := Std; end; else XE.Tref := Ref; XE.Tref_File_Num := File; XE.Tref_Line := Line; XE.Tref_Type := Typ; XE.Tref_Col := Col; XE.Tref_Standard_Entity := Std; end if; end; end loop; -- Loop through cross-references for this entity 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; -- Imported entities reference as in: -- 494b<c,__gnat_copy_attribs>25 if Nextc = '<' then Skipc; XR.Imported_Lang := Get_Name; pragma Assert (Nextc = ','); Skipc; XR.Imported_Name := Get_Name; pragma Assert (Nextc = '>'); Skipc; else XR.Imported_Lang := No_Name; XR.Imported_Name := No_Name; end if; 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; exception when Bad_ALI_Format => -- If ignoring errors, then we skip a line with an -- unexpected error, and try to continue subsequent -- xref lines. if Ignore_Errors then Xref_Entity.Decrement_Last; Skip_Line; C := Nextc; -- Otherwise, we reraise the fatal exception else raise; end if; 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 X_Loop; -- Here after dealing with xref sections -- Ignore remaining lines, which belong to an additional section of the -- ALI file not considered here (like SCO or SPARK information). Check_Unknown_Line; return Id; exception when Bad_ALI_Format => return No_ALI_Id; end Scan_ALI; ----------- -- Scope -- ----------- function Scope (IS_Id : Invocation_Signature_Id) return Name_Id is begin pragma Assert (Present (IS_Id)); return Invocation_Signatures.Table (IS_Id).Scope; end Scope; --------- -- SEq -- --------- function SEq (F1, F2 : String_Ptr) return Boolean is begin return F1.all = F2.all; end SEq; ----------------------------------- -- Set_Invocation_Graph_Encoding -- ----------------------------------- procedure Set_Invocation_Graph_Encoding (Kind : Invocation_Graph_Encoding_Kind; Update_Units : Boolean := True) is begin Compile_Time_Invocation_Graph_Encoding := Kind; -- Update the invocation-graph encoding of the current unit only when -- requested by the caller. if Update_Units then declare Curr_Unit : Unit_Record renames Units.Table (Units.Last); Curr_ALI : ALIs_Record renames ALIs.Table (Curr_Unit.My_ALI); begin Curr_ALI.Invocation_Graph_Encoding := Kind; end; end if; end Set_Invocation_Graph_Encoding; ----------- -- 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; --------------- -- Signature -- --------------- function Signature (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id is begin pragma Assert (Present (IC_Id)); return Invocation_Constructs.Table (IC_Id).Signature; end Signature; -------------------- -- Spec_Placement -- -------------------- function Spec_Placement (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind is begin pragma Assert (Present (IC_Id)); return Invocation_Constructs.Table (IC_Id).Spec_Placement; end Spec_Placement; ------------ -- Target -- ------------ function Target (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id is begin pragma Assert (Present (IR_Id)); return Invocation_Relations.Table (IR_Id).Target; end Target; end ALI;