-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- 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 Namet; use Namet;
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
- -- 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.
+ -----------
+ -- 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 :=
- ('V' => True, -- version
- 'M' => True, -- main program
- 'A' => True, -- argument
- 'P' => True, -- program
- 'R' => True, -- restriction
- 'I' => True, -- interrupt
- 'U' => True, -- unit
- 'W' => True, -- with
- 'L' => True, -- linker option
- 'E' => True, -- external
- 'D' => True, -- dependency
- 'X' => True, -- xref
+ ('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 --
--------------------
-- These two loops are empty and harmless the first time in.
for J in ALIs.First .. ALIs.Last loop
- Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
+ Set_Name_Table_Int (ALIs.Table (J).Afile, 0);
end loop;
for J in Units.First .. Units.Last loop
- Set_Name_Table_Info (Units.Table (J).Uname, 0);
+ Set_Name_Table_Int (Units.Table (J).Uname, 0);
end loop;
-- Free argument table strings
-- 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;
- Sdep.Init;
- Linker_Options.Init;
- Xref_Section.Init;
Xref_Entity.Init;
Xref.Init;
- Version_Ref.Reset;
+ Xref_Section.Init;
- -- Add dummy zero'th item in Linker_Options for the sort function
+ -- 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;
- Float_Format_Specified := ' ';
- Locking_Policy_Specified := ' ';
- No_Normalize_Scalars_Specified := False;
- No_Object_Specified := False;
- Normalize_Scalars_Specified := False;
- Queuing_Policy_Specified := ' ';
- Static_Elaboration_Model_Used := False;
- Task_Dispatching_Policy_Specified := ' ';
- Unreserve_All_Interrupts_Specified := False;
- Zero_Cost_Exceptions_Specified := False;
+ 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) return ALI_Id
+ (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;
+ P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1;
Id : ALI_Id;
C : Character;
-- be ignored by Scan_ALI and skipped, and False if the lines
-- are to be read and processed.
- Restrictions_Initial : Rident.Restrictions_Info;
- pragma Warnings (Off, Restrictions_Initial);
- -- This variable, which should really be a constant (but that's not
- -- allowed by the language) is used only for initialization, and the
- -- reason we are declaring it is to get the default initialization
- -- set for the object.
-
Bad_ALI_Format : exception;
-- Exception raised by Fatal_Error if Err is True
function Getc return Character;
-- Get next character, bumping P past the character obtained
- function Get_Name
+ function Get_File_Name
(Lower : Boolean := False;
- Ignore_Spaces : Boolean := False) return Name_Id;
+ 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 name is terminated by a either
- -- white space (when Ignore_Spaces is False) or a typeref bracket or
- -- an equal sign except for the special case of an operator name
- -- starting with a double quite which is terminated by another double
- -- quote.
+ -- 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
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.
end if;
end Check_At_End_Of_Field;
- ------------
- -- 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;
-
------------------------
-- Check_Unknown_Line --
------------------------
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 --
-----------------
Write_Name (F);
Write_Str (" is incorrectly formatted");
Write_Eol;
- Write_Str
- ("make sure you are using consistent versions of gcc/gnatbind");
+
+ 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
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
- (Lower : Boolean := False;
- Ignore_Spaces : Boolean := False) return Name_Id
+ (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;
end if;
end if;
- loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
+ 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 At_End_Of_Field and not Ignore_Spaces;
+ exit when Nextc = ',';
- if Name_Buffer (1) = '"' then
- exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
+ -- Terminate if left bracket not part of wide char
+ -- sequence Note that we only recognize brackets
+ -- notation so far ???
- else
- exit when (At_End_Of_Field and not Ignore_Spaces)
- or else Nextc = '(' or else Nextc = ')'
- or else Nextc = '{' or else Nextc = '}'
- or else Nextc = '<' or else Nextc = '>'
- or else Nextc = '[' or else Nextc = ']'
- or else Nextc = '=';
- end if;
- end loop;
+ exit when Nextc = '[' and then T (P + 1) /= '"';
- -- 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.
+ -- Terminate if right bracket not part of wide char
+ -- sequence.
- if Lower and not File_Names_Case_Sensitive then
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ 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 --
-------------
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 Nextc > '9';
+ exit when Nextc < '0' or else Nextc > '9';
end loop;
return V;
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;
-
-----------------
-- Get_Typeref --
-----------------
begin
loop
case Nextc is
- when '[' =>
+ when '[' =>
Nested_Brackets := Nested_Brackets + 1;
when ']' =>
Nested_Brackets := Nested_Brackets - 1;
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 --
--------------
-- Acquire lines to be ignored
if Read_Xref then
- Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True);
+ Ignore :=
+ ('T' | 'U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True);
-- Read_Lines parameter given
ALIs.Increment_Last;
Id := ALIs.Last;
- Set_Name_Table_Info (F, Int (Id));
+ 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_Unit => No_Unit_Id,
- Float_Format => 'I',
- Last_Interrupt_State => Interrupt_States.Last,
- Last_Sdep => No_Sdep_Id,
- Last_Unit => No_Unit_Id,
- Locking_Policy => ' ',
- Main_Priority => -1,
- Main_Program => None,
- No_Object => False,
- Normalize_Scalars => False,
- Ofile_Full_Name => Full_Object_File_Name,
- Queuing_Policy => ' ',
- Restrictions => Restrictions_Initial,
- SAL_Interface => False,
- 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);
+ 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,
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;
else
Checkc (' ');
- Name_Len := 0;
+ -- Scan out argument
+
+ Name_Len := 0;
while not At_Eol loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
+ 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));
Checkc ('B');
Detect_Blocking := True;
- -- Processing for FD/FG/FI
+ -- 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
- Float_Format_Specified := Getc;
- ALIs.Table (Id).Float_Format := Float_Format_Specified;
+ 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 = '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
- if C = 'O' then
+ elsif C = 'O' then
ALIs.Table (Id).No_Object := True;
No_Object_Specified := True;
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
C := Getc;
Check_Unknown_Line;
- -- Acquire first restrictions line
+ -- Loop to skip to first restrictions line
while C /= 'R' loop
if Ignore_Errors then
end if;
end loop;
+ -- Ignore all 'R' lines if that is required
+
if Ignore ('R') then
- Skip_Line;
+ 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 =>
- -- Process restrictions line
+ -- A constraint error comes from the
+ -- addition. We reset to the maximum
+ -- and indicate that the real value
+ -- is now unknown.
- else
- Scan_Restrictions : declare
- Save_R : constant Restrictions_Info := Cumulative_Restrictions;
- -- Save cumulative restrictions in case we have a fatal error
+ Cumulative_Restrictions.Value (R) :=
+ Integer'Last;
+ Cumulative_Restrictions.Unknown (R) :=
+ True;
+ end;
+ end if;
- Bad_R_Line : exception;
- -- Signal bad restrictions line (raised on unexpected character)
+ -- Deal with + case
- begin
- Checkc (' ');
- Skip_Space;
+ if Nextc = '+' then
+ Skipc;
+ ALIs.Table (Id).Restrictions.Unknown (R) :=
+ True;
+ Cumulative_Restrictions.Unknown (R) := True;
+ end if;
- -- Acquire information for boolean restrictions
+ -- Other than 'R' or 'V'
- for R in All_Boolean_Restrictions loop
- C := Getc;
+ when others =>
+ raise Bad_R_Line;
+ end case;
- case C is
- when 'v' =>
- ALIs.Table (Id).Restrictions.Violated (R) := True;
- Cumulative_Restrictions.Violated (R) := True;
+ if not At_Eol then
+ raise Bad_R_Line;
+ end if;
- when 'r' =>
- ALIs.Table (Id).Restrictions.Set (R) := True;
- Cumulative_Restrictions.Set (R) := True;
+ -- Bizarre error case NOT_A_RESTRICTION
- when 'n' =>
- null;
+ when Not_A_Restriction_Id =>
+ raise Bad_R_Line;
+ end case;
- when others =>
+ if not At_Eol then
raise Bad_R_Line;
- end case;
- end loop;
+ end if;
- -- Acquire information for parameter restrictions
+ <<Done_With_Restriction_Line>>
+ Skip_Line;
+ C := Getc;
+ end loop;
- for RP in All_Parameter_Restrictions loop
+ -- Positional restriction case
- -- Acquire restrictions pragma information
+ else
+ Checkc (' ');
+ Skip_Space;
- case Getc is
- when 'n' =>
- null;
+ -- Acquire information for boolean restrictions
- when 'r' =>
- ALIs.Table (Id).Restrictions.Set (RP) := True;
+ for R in All_Boolean_Restrictions loop
+ C := Getc;
- declare
- N : constant Integer := Integer (Get_Nat);
- begin
- ALIs.Table (Id).Restrictions.Value (RP) := N;
+ case C is
+ when 'v' =>
+ ALIs.Table (Id).Restrictions.Violated (R) := True;
+ Cumulative_Restrictions.Violated (R) := True;
- 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 'r' =>
+ ALIs.Table (Id).Restrictions.Set (R) := True;
+ Cumulative_Restrictions.Set (R) := True;
- when others =>
- raise Bad_R_Line;
- end case;
+ 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
+ -- Acquire restrictions violations information
+
+ case Getc is
- case Getc is
when 'n' =>
null;
declare
N : constant Integer := Integer (Get_Nat);
- pragma Unsuppress (Overflow_Check);
begin
ALIs.Table (Id).Restrictions.Count (RP) := N;
Cumulative_Restrictions.Count (RP) :=
Integer'Max
(Cumulative_Restrictions.Count (RP), N);
+
else
- Cumulative_Restrictions.Count (RP) :=
- Cumulative_Restrictions.Count (RP) + N;
- end if;
+ declare
+ pragma Unsuppress (Overflow_Check);
- exception
- when Constraint_Error =>
+ begin
+ Cumulative_Restrictions.Count (RP) :=
+ Cumulative_Restrictions.Count (RP) + N;
- -- A constraint error comes from the addition in
- -- the else branch. We reset to the maximum and
- -- indicate that the real value is now unknown.
+ exception
+ when Constraint_Error =>
- Cumulative_Restrictions.Value (RP) := Integer'Last;
+ -- 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;
- if Nextc = '+' then
- Skipc;
- ALIs.Table (Id).Restrictions.Unknown (RP) := True;
- Cumulative_Restrictions.Unknown (RP) := True;
- end if;
-
when others =>
raise Bad_R_Line;
- end case;
- end loop;
+ end case;
+ end loop;
- Skip_Eol;
+ 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
when Bad_R_Line =>
-- In Ignore_Errors mode, undo any changes to restrictions
- -- from this unit, and continue on.
+ -- 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 := Restrictions_Initial;
- Skip_Eol;
+ 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
- C := Getc;
while C = 'R' loop
if Ignore ('R') then
Skip_Line;
else
Skip_Space;
No_Deps.Append ((Id, Get_Name));
+ Skip_Eol;
end if;
- Skip_Eol;
C := Getc;
end loop;
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
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;
- Units.Table (Units.Last).SAL_Interface := ALIs.Table (Id).
- SAL_Interface;
- Units.Table (Units.Last).Body_Needed_For_SAL := False;
-
- if Debug_Flag_U then
- Write_Str (" ----> reading unit ");
- Write_Int (Int (Units.Last));
- Write_Str (" ");
- Write_Unit_Name (Units.Table (Units.Last).Uname);
- Write_Str (" from file ");
- Write_Name (Units.Table (Units.Last).Sfile);
- Write_Eol;
- 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_Info
+ Info : constant Int := Get_Name_Table_Int
(Units.Table (Units.Last).Uname);
begin
if Info /= 0
end if;
end;
- Set_Name_Table_Info
+ Set_Name_Table_Int
(Units.Table (Units.Last).Uname, Int (Units.Last));
-- Scan out possible version and other parameters
Units.Table (Units.Last).Version (J) := C;
end loop;
- -- BN parameter (Body needed)
+ -- BD/BN parameters
elsif C = 'B' then
C := Getc;
- if C = 'N' then
+ 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;
Fatal_Error_Ignore;
end if;
- -- PR/PU/PK parameters
+ -- PF/PR/PU/PK parameters
elsif C = 'P' then
C := Getc;
- if C = 'R' then
+ 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;
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
Check_At_End_Of_Field;
+ -- SE/SP/SU parameters
+
elsif C = 'S' then
C := Getc;
- if C = 'P' then
+ 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';
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;
-
C := Getc;
-- Scan out With lines for this unit
With_Loop : loop
Check_Unknown_Line;
- exit With_Loop when C /= 'W';
+ exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
if Ignore ('W') then
Skip_Line;
Checkc (' ');
Skip_Space;
Withs.Increment_Last;
- Withs.Table (Withs.Last).Uname := Get_Name;
+ 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
-- Normal case
else
- Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
- Withs.Table (Withs.Last).Afile := Get_Name;
+ 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, and NE parameters
+ -- Scan out possible E, EA, ED, and AD parameters
while not At_Eol loop
Skip_Space;
- if Nextc = 'E' then
+ 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
-- Store ED indication unless ignore required
if not Ignore_ED then
- Withs.Table (Withs.Last).Elab_All_Desirable :=
+ Withs.Table (Withs.Last).Elab_Desirable :=
True;
end if;
end if;
+
+ else
+ Fatal_Error;
end if;
end loop;
end if;
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;
end if;
end loop;
- Add_Char_To_Name_Buffer (nul);
+ Add_Char_To_Name_Buffer (NUL);
Skip_Eol;
end if;
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 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
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!
+ -- is that Uname drags in far too much compiler junk.
Get_Name_String (Units.Table (Units.Last).Uname);
Checkc (' ');
Skip_Space;
Sdep.Increment_Last;
- Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
+
+ -- 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);
end if;
end;
- -- Acquire subunit and reference file name entries
+ -- 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 subunit name
+ -- Here for (sub)unit 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;
+ Add_Char_To_Name_Buffer (Getc);
end loop;
- Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
+ -- 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;
Name_Len := 0;
while not At_End_Of_Field loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
+ Add_Char_To_Name_Buffer (Getc);
end loop;
Sdep.Table (Sdep.Last).Rfile := Name_Enter;
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
begin
XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
- XS.File_Name := Get_Name;
+ XS.File_Name := Get_File_Name;
XS.First_Entity := Xref_Entity.Last + 1;
Current_File_Num := XS.File_Num;
-- 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.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
Skip_Space;
- -- See if type reference present
+ XE.Oref_File_Num := No_Sdep_Id;
+ XE.Tref_File_Num := No_Sdep_Id;
+ XE.Tref := Tref_None;
+ XE.First_Xref := Xref.Last + 1;
- Get_Typeref
- (Current_File_Num, XE.Tref, XE.Tref_File_Num, XE.Tref_Line,
- XE.Tref_Type, XE.Tref_Col, XE.Tref_Standard_Entity);
+ -- Loop to check for additional info present
- -- Do we have an overriding procedure, instead ?
- if XE.Tref_Type = 'p' then
- XE.Oref_File_Num := XE.Tref_File_Num;
- XE.Oref_Line := XE.Tref_Line;
- XE.Oref_Col := XE.Tref_Col;
- XE.Tref_File_Num := No_Sdep_Id;
- XE.Tref := Tref_None;
- else
- -- We might have additional information about the
- -- overloaded subprograms
+ loop
declare
- Ref : Tref_Kind;
- Typ : Character;
- Standard_Entity : Name_Id;
+ Ref : Tref_Kind;
+ File : Sdep_Id;
+ Line : Nat;
+ Typ : Character;
+ Col : Nat;
+ Std : Name_Id;
+
begin
Get_Typeref
- (Current_File_Num,
- Ref, XE.Oref_File_Num,
- XE.Oref_Line, Typ, XE.Oref_Col, Standard_Entity);
- end;
- end if;
+ (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;
- XE.First_Xref := Xref.Last + 1;
+ 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
-- Imported entities reference as in:
-- 494b<c,__gnat_copy_attribs>25
- -- ??? Simply skipped for now
if Nextc = '<' then
- while Getc /= '>' loop
- null;
- end loop;
+ 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;
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;
-- Here after dealing with xref sections
- if C /= EOF and then C /= 'X' then
- Fatal_Error;
- end if;
+ -- 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 --
---------
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 --
-----------
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;