-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
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
- 'S' => True, -- specific dispatching
- 'Y' => True, -- limited_with
+ ('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;
function Getc return Character;
-- Get next character, bumping P past the character obtained
- function Get_File_Name (Lower : Boolean := False) return File_Name_Type;
+ 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
function Get_Name
(Ignore_Spaces : Boolean := False;
- Ignore_Special : Boolean := False)return Name_Id;
+ 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
--
-- 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 quite which is terminated
+ -- 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.
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.
Write_Str ("make sure you are using consistent versions " &
-- Split the following line so that it can easily be transformed for
- -- e.g. JVM/.NET back-ends where the compiler has a different name.
+ -- other back-ends where the compiler might have a different name.
"of gcc/gnatbind");
-------------------
function Get_File_Name
- (Lower : Boolean := False) return File_Name_Type
+ (Lower : Boolean := False;
+ May_Be_Quoted : Boolean := False) return File_Name_Type
is
F : Name_Id;
begin
- F := Get_Name (Ignore_Special => True);
+ 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
function Get_Name
(Ignore_Spaces : Boolean := False;
- Ignore_Special : Boolean := False) return Name_Id
+ 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
- Add_Char_To_Name_Buffer (Getc);
+ Char := Getc;
+
+ -- Deal with quoted characters
- exit when At_End_Of_Field and then not Ignore_Spaces;
+ 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;
- if not Ignore_Special then
- if Name_Buffer (1) = '"' then
- exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
+ Char := Getc;
- else
- -- Terminate on parens or angle brackets or equal sign
+ if Char = '"' then
+ if At_Eol then
+ exit;
- exit when Nextc = '(' or else Nextc = ')'
- or else Nextc = '{' or else Nextc = '}'
- or else Nextc = '<' or else Nextc = '>'
- or else Nextc = '=';
+ else
+ Char := Getc;
- -- Terminate if left bracket not part of wide char sequence
- -- Note that we only recognize brackets notation so far ???
+ if Char /= '"' then
+ P := P - 1;
+ exit;
+ end if;
+ end if;
+ end if;
- exit when Nextc = '[' and then T (P + 1) /= '"';
+ 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
- -- Terminate if right bracket not part of wide char sequence
+ exit when Nextc = '(' or else Nextc = ')'
+ or else Nextc = '{' or else Nextc = '}'
+ or else Nextc = '<' or else Nextc = '>'
+ or else Nextc = '=';
- exit when Nextc = ']' and then T (P - 1) /= '"';
+ -- 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 if;
- end loop;
+ end loop;
+ end if;
return Name_Find;
end Get_Name;
begin
loop
case Nextc is
- when '[' =>
+ when '[' =>
Nested_Brackets := Nested_Brackets + 1;
when ']' =>
Nested_Brackets := Nested_Brackets - 1;
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' | 'Y' | '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_Specific_Dispatching => Specific_Dispatching.Last + 1,
- First_Unit => No_Unit_Id,
- Float_Format => 'I',
- 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_Program => None,
- No_Object => False,
- Normalize_Scalars => False,
- Ofile_Full_Name => Full_Object_File_Name,
- Queuing_Policy => ' ',
- Restrictions => No_Restrictions,
- SAL_Interface => False,
- Sfile => No_File,
- Task_Dispatching_Policy => ' ',
- Time_Slice_Value => -1,
- WC_Encoding => 'b',
- 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;
Add_Char_To_Name_Buffer (Getc);
end loop;
- -- If -fstack-check, record that it occurred
+ -- 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_Buffer (1 .. Name_Len) = "-fstack-check" then
+ 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;
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;
- -- Process restrictions line
+ -- Here we process the restrictions lines (other than unit name cases)
else
Scan_Restrictions : declare
Bad_R_Line : exception;
-- Signal bad restrictions line (raised on unexpected character)
- begin
- Checkc (' ');
- Skip_Space;
+ Typ : Character;
+ R : Restriction_Id;
+ N : Natural;
- -- Acquire information for boolean restrictions
+ begin
+ -- Named restriction case
- for R in All_Boolean_Restrictions loop
+ if Nextc = 'N' then
+ Skip_Line;
C := Getc;
- case C is
- when 'v' =>
- ALIs.Table (Id).Restrictions.Violated (R) := True;
- Cumulative_Restrictions.Violated (R) := True;
+ -- Loop through RR and RV lines
- when 'r' =>
- ALIs.Table (Id).Restrictions.Set (R) := True;
- Cumulative_Restrictions.Set (R) := True;
+ while C = 'R' and then Nextc /= ' ' loop
+ Typ := Getc;
+ Checkc (' ');
- when 'n' =>
- null;
+ -- Acquire restriction name
- when others =>
- raise Bad_R_Line;
- end case;
- end loop;
+ Name_Len := 0;
+ while not At_Eol and then Nextc /= '=' loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
- -- Acquire information for parameter restrictions
+ -- Now search list of restrictions to find match
- for RP in All_Parameter_Restrictions loop
+ declare
+ RN : String renames Name_Buffer (1 .. Name_Len);
- -- Acquire restrictions pragma information
+ begin
+ R := Restriction_Id'First;
+ while R /= Not_A_Restriction_Id loop
+ if Restriction_Id'Image (R) = RN then
+ goto R_Found;
+ end if;
- case Getc is
- when 'n' =>
- null;
+ R := Restriction_Id'Succ (R);
+ end loop;
- when 'r' =>
- ALIs.Table (Id).Restrictions.Set (RP) := True;
+ -- 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.
- declare
- N : constant Integer := Integer (Get_Nat);
- begin
- ALIs.Table (Id).Restrictions.Value (RP) := N;
+ 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;
- if Cumulative_Restrictions.Set (RP) then
- Cumulative_Restrictions.Value (RP) :=
- Integer'Min
- (Cumulative_Restrictions.Value (RP), N);
+ -- Parameter restriction case
+
+ when All_Parameter_Restrictions =>
+ if At_Eol or else Nextc /= '=' then
+ raise Bad_R_Line;
else
- Cumulative_Restrictions.Set (RP) := True;
- Cumulative_Restrictions.Value (RP) := N;
+ Skipc;
end if;
- end;
- when others =>
+ 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 case;
+ end if;
+
+ <<Done_With_Restriction_Line>>
+ Skip_Line;
+ C := Getc;
+ end loop;
- -- Acquire restrictions violations information
+ -- 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
- 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);
+
+ begin
+ Cumulative_Restrictions.Count (RP) :=
+ Cumulative_Restrictions.Count (RP) + N;
- exception
- when Constraint_Error =>
+ exception
+ when Constraint_Error =>
- -- 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.
+ -- 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.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 := No_Restrictions;
- Skip_Eol;
+
+ 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;
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.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.Elab_Position := 0;
- UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
- UL.Body_Needed_For_SAL := False;
- UL.Elaborate_Body_Desirable := False;
- UL.Optimize_Alignment := 'O';
+ 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 ");
-- 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
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;
+ -- 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' and then C /= 'Y';
+ exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
if Ignore ('W') then
Skip_Line;
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
-- Store AD indication unless ignore required
if not Ignore_ED then
- Withs.Table (Withs.Last).Elab_All_Desirable :=
- True;
+ Withs.Table (Withs.Last).Elab_All_Desirable := True;
end if;
elsif Nextc = 'E' then
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.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);
-- 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???
- Sdep.Table (Sdep.Last).Sfile := Get_File_Name;
+ -- 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 :=
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;
Add_Char_To_Name_Buffer (Getc);
end loop;
- -- Set the subunit name. Note that we use Name_Find rather
+ -- 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.
- Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
+ 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;
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
-- 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
-- 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;
-- 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;
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;
projects / gcc.git / blobdiff