+2012-10-01 Vincent Pucci <pucci@adacore.com>
+
+ * s-gearop.adb (Vector_Matrix_Product): Dimensions check fixed. Index
+ of Left in S evaluation fixed.
+
+2012-10-01 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Avoid
+ premature freezing caused by the internally generated subprogram
+ _postconditions.
+ * checks.adb (Expr_Known_Valid): Float literals are assumed to be valid
+ in VM targets.
+
+2012-10-01 Thomas Quinot <quinot@adacore.com>
+
+ * sinput.ads, sinput.adb, sinput-l.adb sinput-c.adb (Sinput): New
+ Instances table, tracking all generic instantiations. Source file
+ attribute Instance replaces previous Instantiation attribute with an
+ index into the Instances table.
+ (Iterate_On_Instances): New generic procedure.
+ (Create_Instantiation_Source): Record instantiations in Instances.
+ (Tree_Read, Tree_Write): Read/write the instance table.
+ * scils.ads, scos.adb (SCO_Instance_Table): New table, contains
+ information copied from Sinput.Instance_Table, but self-contained
+ within the SCO data structures.
+ * par_sco.ads, par_sco.adb (To_Source_Location): Move to library level.
+ (Record_Instance): New subprogram, used by...
+ (Populate_SCO_Instance_Table): New subprogram to fill
+ the SCO instance table from the Sinput one (called by SCO_Output).
+ * opt.ads (Generate_SCO_Instance_Table): New option.
+ * put_scos.adb (Write_Instance_Table): New subprogram, used by...
+ (Put_SCOs): Dump the instance table at the end of SCO information
+ if requested.
+ * get_scos.adb (Get_SCOs): Read SCO_Instance_Table.
+ * types.h: Add declaration for Instance_Id.
+ * back_end.adb (Call_Back_End): Pass instance ids in source file
+ information table.
+ (Scan_Back_End_Switches): -fdebug-instances sets
+ Opt.Generate_SCO_Instance_Table.
+ * gcc-interface/gigi.h: File_Info_Type includes instance id.
+ * gcc-interface/trans.c: Under -fdebug-instances, set instance
+ id in line map from same in file info.
+
+2012-10-01 Thomas Quinot <quinot@adacore.com>
+
+ * sem_elab.adb: Minor reformatting
+ (Check_Elab_Call): Minor fix to debugging code
+ (add special circuit for the valid case where a 'Access attribute
+ reference is passed to Check_Elab_Call).
+
+2012-10-01 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch3.adb: Minor reformatting.
+
2012-10-01 Ed Schonberg <schonberg@adacore.com>
* exp_ch3.ads (Build_Array_Invariant_Proc): moved to body.
type File_Info_Type is record
File_Name : File_Name_Type;
+ Instance : Instance_Id;
Num_Source_Lines : Nat;
end record;
for J in 1 .. Last_Source_File loop
File_Info_Array (J).File_Name := Full_Debug_Name (J);
+ File_Info_Array (J).Instance := Instance (J);
File_Info_Array (J).Num_Source_Lines :=
Nat (Physical_To_Logical (Last_Source_Line (J), J));
end loop;
elsif Switch_Chars (First .. Last) = "fdump-scos" then
Opt.Generate_SCO := True;
+ -- Back end switch -fdebug-instances also enables instance table
+ -- SCO generation.
+
+ elsif Switch_Chars (First .. Last) = "fdebug-instances" then
+ Opt.Generate_SCO_Instance_Table := True;
+
end if;
end if;
end Scan_Back_End_Switches;
then
return True;
+ -- Real literals are assumed to be valid in VM targets
+
+ elsif VM_Target /= No_VM
+ and then Nkind (Expr) = N_Real_Literal
+ then
+ return True;
+
-- If we have a type conversion or a qualification of a known valid
-- value, then the result will always be valid.
-- but it properly belongs with the array type declaration. However, if
-- the freeze node is for a subtype of a type declared in another unit
-- it seems preferable to use the freeze node as the source location of
- -- of the init proc. In any case this is preferable for gcov usage, and
+ -- the init proc. In any case this is preferable for gcov usage, and
-- the Sloc is not otherwise used by the compiler.
if In_Open_Scopes (Scope (A_Type)) then
struct File_Info_Type
{
File_Name_Type File_Name;
- Nat Num_Source_Lines;
+ Instance_Id Instance;
+ Nat Num_Source_Lines;
};
#ifdef __cplusplus
tree int64_type = gnat_type_for_size (64, 0);
struct elab_info *info;
int i;
+ struct line_map *map;
max_gnat_nodes = max_gnat_node;
/* We create the line map for a source file at once, with a fixed number
of columns chosen to avoid jumping over the next power of 2. */
- linemap_add (line_table, LC_ENTER, 0, filename, 1);
+ map = (struct line_map *) linemap_add
+ (line_table, LC_ENTER, 0, filename, 1);
+#ifdef ORDINARY_MAP_INSTANCE
+ if (flag_debug_instances)
+ ORDINARY_MAP_INSTANCE(map) = file_info_ptr[i].Instance;
+#endif
linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
linemap_position_for_column (line_table, 252 - 1);
linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
case C is
- -- Header entry
+ -- Header or instance table entry
when ' ' =>
SCO_Table.Last;
end if;
- -- Scan out dependency number and file name
-
Skip_Spaces;
- Dnum := Get_Int;
- Skip_Spaces;
+ case Nextc is
- N := 0;
- while Nextc > ' ' loop
- N := N + 1;
- Buf (N) := Getc;
- end loop;
+ -- Instance table entry
+
+ when 'i' =>
+ declare
+ Inum : SCO_Instance_Index;
+ begin
+ Skipc;
+ Skip_Spaces;
+
+ Inum := SCO_Instance_Index (Get_Int);
+ SCO_Instance_Table.Increment_Last;
+ pragma Assert (SCO_Instance_Table.Last = Inum);
+
+ Skip_Spaces;
+ declare
+ SIE : SCO_Instance_Table_Entry
+ renames SCO_Instance_Table.Table (Inum);
+ begin
+ SIE.Inst_Dep_Num := Get_Int;
+ C := Getc;
+ pragma Assert (C = '|');
+ Get_Source_Location (SIE.Inst_Loc);
+
+ if not At_EOL then
+ Skip_Spaces;
+ SIE.Enclosing_Instance :=
+ SCO_Instance_Index (Get_Int);
+ pragma Assert (SIE.Enclosing_Instance in
+ SCO_Instance_Table.First
+ .. SCO_Instance_Table.Last);
+ end if;
+ end;
+ end;
- -- Make new unit table entry (will fill in To later)
+ -- Unit header
+
+ when '0' .. '9' =>
+ -- Scan out dependency number and file name
+
+ Dnum := Get_Int;
+
+ Skip_Spaces;
+
+ N := 0;
+ while Nextc > ' ' loop
+ N := N + 1;
+ Buf (N) := Getc;
+ end loop;
+
+ -- Make new unit table entry (will fill in To later)
+
+ SCO_Unit_Table.Append (
+ (File_Name => new String'(Buf (1 .. N)),
+ Dep_Num => Dnum,
+ From => SCO_Table.Last + 1,
+ To => 0));
+
+ when others =>
+ raise Program_Error;
- SCO_Unit_Table.Append (
- (File_Name => new String'(Buf (1 .. N)),
- Dep_Num => Dnum,
- From => SCO_Table.Last + 1,
- To => 0));
+ end case;
-- Statement entry
Generate_SCO : Boolean := False;
-- GNAT
- -- True when switch -gnateS is used. When True, Source Coverage Obligation
- -- (SCO) information is generated and output in the ALI file. See unit
- -- Par_SCO for full details.
+ -- True when switch -fdump-scos (or -gnateS) is used. When True, Source
+ -- Coverage Obligation (SCO) information is generated and output in the ALI
+ -- file. See unit Par_SCO for full details.
+
+ Generate_SCO_Instance_Table : Boolean := False;
+ -- GNAT
+ -- True when switch -fdebug-instances is used. When True, a table of
+ -- instances is included in SCOs.
Generating_Code : Boolean := False;
-- GNAT
-- excluding OR and AND) and returns True if so, False otherwise, it does
-- no other processing.
+ function To_Source_Location (S : Source_Ptr) return Source_Location;
+ -- Converts Source_Ptr value to Source_Location (line/col) format
+
procedure Process_Decisions
(N : Node_Id;
T : Character;
end record;
No_Dominant : constant Dominant_Info := (' ', Empty);
+ procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr);
+ -- Add one entry from the instance table to the corresponding SCO table
+
procedure Traverse_Declarations_Or_Statements
(L : List_Id;
D : Dominant_Info := No_Dominant;
Debug_Put_SCOs;
end pscos;
+ ---------------------
+ -- Record_Instance --
+ ---------------------
+
+ procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is
+ Inst_Src : constant Source_File_Index :=
+ Get_Source_File_Index (Inst_Sloc);
+ begin
+ SCO_Instance_Table.Append
+ ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)),
+ Inst_Loc => To_Source_Location (Inst_Sloc),
+ Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src))));
+ pragma Assert
+ (SCO_Instance_Table.Last = SCO_Instance_Index (Id));
+ end Record_Instance;
+
----------------
-- SCO_Output --
----------------
procedure SCO_Output is
+ procedure Populate_SCO_Instance_Table is
+ new Sinput.Iterate_On_Instances (Record_Instance);
+
begin
if Debug_Flag_Dot_OO then
dsco;
end if;
+ Populate_SCO_Instance_Table;
+
-- Sort the unit tables based on dependency numbers
Unit_Table_Sort : declare
Pragma_Sloc : Source_Ptr := No_Location;
Pragma_Name : Pragma_Id := Unknown_Pragma)
is
- function To_Source_Location (S : Source_Ptr) return Source_Location;
- -- Converts Source_Ptr value to Source_Location (line/col) format
-
- ------------------------
- -- To_Source_Location --
- ------------------------
-
- function To_Source_Location (S : Source_Ptr) return Source_Location is
- begin
- if S = No_Location then
- return No_Source_Location;
- else
- return
- (Line => Get_Logical_Line_Number (S),
- Col => Get_Column_Number (S));
- end if;
- end To_Source_Location;
-
- -- Start of processing for Set_Table_Entry
-
begin
SCO_Table.Append
((C1 => C1,
Pragma_Name => Pragma_Name));
end Set_Table_Entry;
+ ------------------------
+ -- To_Source_Location --
+ ------------------------
+
+ function To_Source_Location (S : Source_Ptr) return Source_Location is
+ begin
+ if S = No_Location then
+ return No_Source_Location;
+ else
+ return
+ (Line => Get_Logical_Line_Number (S),
+ Col => Get_Column_Number (S));
+ end if;
+ end To_Source_Location;
+
-----------------------------------------
-- Traverse_Declarations_Or_Statements --
-----------------------------------------
-- True if Loc is the source location of a disabled pragma
procedure SCO_Output;
- -- Outputs SCO lines for all units, with appropriate section headers, for
- -- unit U in the ALI file, as recorded by previous calls to SCO_Record,
- -- possibly modified by calls to Set_SCO_Condition.
+ -- Outputs SCO lines for all units, with appropriate section headers, as
+ -- recorded by previous calls to SCO_Record, possibly modified by calls to
+ -- Set_SCO_Condition.
procedure dsco;
-- Debug routine to dump internal SCO table. This is a raw format dump
-- --
------------------------------------------------------------------------------
+with Opt; use Opt;
with Par_SCO; use Par_SCO;
with SCOs; use SCOs;
with Snames; use Snames;
procedure Write_SCO_Initiate (SU : SCO_Unit_Index);
-- Start SCO line for unit SU, also emitting SCO unit header if necessary
+ procedure Write_Instance_Table;
+ -- Output the SCO table of instances
+
procedure Output_Range (T : SCO_Table_Entry);
-- Outputs T.From and T.To in line:col-line:col format
end loop;
end Output_String;
+ --------------------------
+ -- Write_Instance_Table --
+ --------------------------
+
+ procedure Write_Instance_Table is
+ begin
+ for J in 1 .. SCO_Instance_Table.Last loop
+ declare
+ SIE : SCO_Instance_Table_Entry
+ renames SCO_Instance_Table.Table (J);
+ begin
+ Output_String ("C i ");
+ Write_Info_Nat (Nat (J));
+ Write_Info_Char (' ');
+ Write_Info_Nat (SIE.Inst_Dep_Num);
+ Write_Info_Char ('|');
+ Output_Source_Location (SIE.Inst_Loc);
+
+ if SIE.Enclosing_Instance > 0 then
+ Write_Info_Char (' ');
+ Write_Info_Nat (Nat (SIE.Enclosing_Instance));
+ end if;
+ Write_Info_Terminate;
+ end;
+ end loop;
+ end Write_Instance_Table;
+
------------------------
-- Write_SCO_Initiate --
------------------------
end loop;
end;
end loop;
+
+ if Opt.Generate_SCO_Instance_Table then
+ Write_Instance_Table;
+ end if;
end Put_SCOs;
is
begin
return R : Result_Vector (Right'Range (2)) do
- if Left'Length /= Right'Length (2) then
+ if Left'Length /= Right'Length (1) then
raise Constraint_Error with
"incompatible dimensions in vector-matrix multiplication";
end if;
begin
for K in Right'Range (1) loop
- S := S + Left (J - Right'First (1)
+ S := S + Left (K - Right'First (1)
+ Left'First) * Right (K, J);
end loop;
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2012, 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- --
begin
SCO_Table.Init;
SCO_Unit_Table.Init;
+ SCO_Instance_Table.Init;
-- Set dummy zeroth entry for sort routine, real entries start at 1
-- For each decision, a decision line is generated with the form:
- -- C* sloc expression [chaining]
+ -- C* sloc expression
-- Here * is one of the following characters:
-- condition, and that is true even if the Ada 2005 set membership
-- form is used, e.g. A in (2,7,11.15).
- -- The expression can be followed by chaining indicators of the form
- -- Tsloc-range or Fsloc-range, where the sloc-range is that of some
- -- entry on a CS line.
-
- -- T* is present when the statement with the given sloc range is executed
- -- if, and only if, the decision evaluates to TRUE.
-
- -- F* is present when the statement with the given sloc range is executed
- -- if, and only if, the decision evaluates to FALSE.
-
- -- For an IF statement or ELSIF part, a T chaining indicator is always
- -- present, with the sloc range of the first statement in the
- -- corresponding sequence.
-
- -- For an ELSE part, the last decision in the IF statement (that of the
- -- last ELSIF part, if any, or that of the IF statement if there is no
- -- ELSIF part) has an F chaining indicator with the sloc range of the
- -- first statement in the sequence of the ELSE part.
-
- -- For a WHILE loop, a T chaining indicator is always present, with the
- -- sloc range of the first statement in the loop, but no F chaining
- -- indicator is ever present.
-
- -- For an EXIT WHEN statement, an F chaining indicator is present if
- -- there is an immediately following sequence in the same sequence of
- -- statements.
-
- -- In all other cases, chaining indicators are omitted
-
-- Implementation permission: a SCO generator is permitted to emit a
-- narrower SLOC range for a condition if the corresponding code
-- generation circuitry ensures that all debug information for the code
-- entries appear in one logical statement sequence, continuation lines
-- are marked by Cc and appear immediately after the CC line.
+ -- Generic instances
+
+ -- A table of all generic instantiations in the compilation is generated
+ -- whose entries have the form:
+
+ -- C i index dependency-number|sloc [enclosing]
+
+ -- Where index is the 1-based index of the entry in the table,
+ -- dependency-number and sloc indicate the source location of the
+ -- instantiation, and enclosing is the index of the enclosing
+ -- instantiation in the table (for a nested instantiation), or is
+ -- omitted for an outer instantiation.
+
-- Disabled pragmas
-- No SCO is generated for disabled pragmas
-- To = ending source location
-- Last = False for all but the last entry, True for last entry
- -- Element (chaining indicator)
- -- C1 = 'H' (cHain)
- -- C2 = 'T' or 'F' (chaining on decision true/false)
- -- From = starting source location of chained statement
- -- To = ending source location of chained statement
-
-- Note: the sequence starting with a decision, and continuing with
-- operators and elements up to and including the first one labeled with
-- Last = True, indicate the sequence to be output on one decision line.
Table_Initial => 20,
Table_Increment => 200);
+ -----------------------
+ -- Generic instances --
+ -----------------------
+
+ type SCO_Instance_Index is new Nat;
+
+ type SCO_Instance_Table_Entry is record
+ Inst_Dep_Num : Nat;
+ Inst_Loc : Source_Location;
+ -- File and source location of instantiation
+
+ Enclosing_Instance : SCO_Instance_Index;
+ end record;
+
+ package SCO_Instance_Table is new GNAT.Table (
+ Table_Component_Type => SCO_Instance_Table_Entry,
+ Table_Index_Type => SCO_Instance_Index,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 200);
+
-----------------
-- Subprograms --
-----------------
-- explicitly checked that all required types are properly frozen,
-- and we do not cause general freezing here. This special circuit
-- is used when the encountered body is marked as having already
- -- been analyzed.
+ -- been analyzed (although we must take into account the special
+ -- case of the internally generated subprogram _postconditions,
+ -- may not have been analyzed yet)
-- In all other cases (bodies that come from source, and expander
-- generated bodies that have not been analyzed yet), freeze all
N_Task_Body)
or else
Nkind (Next_Node) in N_Body_Stub)
+ and then not
+ (Ada_Version = Ada_2012
+ and then Nkind (Next_Node) = N_Subprogram_Body
+ and then Chars (Defining_Entity (Next_Node))
+ = Name_uPostconditions)
then
Adjust_D;
Freeze_All (Freeze_From, D);
-- This is set True till the compilation is complete, including the
-- insertion of all instance bodies. Then when Check_Elab_Calls is called,
-- the delay table is used to make the delayed calls and this flag is reset
- -- to False, so that the calls are processed
+ -- to False, so that the calls are processed.
-----------------------
-- Local Subprograms --
Ent : Entity_Id;
P : Node_Id;
- -- Start of processing for Check_Elab_Call
-
begin
-- If the call does not come from the main unit, there is nothing to
-- check. Elaboration call from units in the context of the main unit
if Debug_Flag_LL then
Write_Str (" Check_Elab_Call: ");
- if No (Name (N))
- or else not Is_Entity_Name (Name (N))
- then
+ if Nkind (N) = N_Attribute_Reference then
+ if not Is_Entity_Name (Prefix (N)) then
+ Write_Str ("<<not entity name>>");
+ else
+ Write_Name (Chars (Entity (Prefix (N))));
+ end if;
+ Write_Str ("'Access");
+
+ elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then
Write_Str ("<<not entity name>> ");
+
else
Write_Name (Chars (Entity (Name (N))));
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
Full_Debug_Name => Path_Id,
Full_File_Name => Path_Id,
Full_Ref_Name => Path_Id,
+ Instance => No_Instance_Id,
Identifier_Casing => Unknown,
+ Inlined_Call => No_Location,
Inlined_Body => False,
- Instantiation => No_Location,
Keyword_Casing => Unknown,
Last_Source_Line => 1,
License => Unknown,
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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 Prepcomp; use Prepcomp;
with Scans; use Scans;
with Scn; use Scn;
+with Sem_Aux; use Sem_Aux;
+with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with System; use System;
Source_File.Append (Source_File.Table (Xold));
Xnew := Source_File.Last;
- Source_File.Table (Xnew).Inlined_Body := Inlined_Body;
- Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
- Source_File.Table (Xnew).Template := Xold;
+ declare
+ Sold : Source_File_Record renames Source_File.Table (Xold);
+ Snew : Source_File_Record renames Source_File.Table (Xnew);
- -- Now we need to compute the new values of Source_First, Source_Last
- -- and adjust the source file pointer to have the correct virtual
- -- origin for the new range of values.
+ Inst_Spec : Node_Id;
- Source_File.Table (Xnew).Source_First :=
- Source_File.Table (Xnew - 1).Source_Last + 1;
- A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
- Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
+ begin
+ Snew.Inlined_Body := Inlined_Body;
+ Snew.Template := Xold;
- Set_Source_File_Index_Table (Xnew);
+ -- For a genuine generic instantiation, assign new instance id.
+ -- For inlined bodies, we retain that of the template, but we
+ -- save the call location.
- Source_File.Table (Xnew).Sloc_Adjust :=
- Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
+ if Inlined_Body then
+ Snew.Inlined_Call := Sloc (Inst_Node);
- if Debug_Flag_L then
- Write_Eol;
- Write_Str ("*** Create instantiation source for ");
+ else
- if Nkind (Dnod) in N_Proper_Body
- and then Was_Originally_Stub (Dnod)
- then
- Write_Str ("subunit ");
+ -- If the spec has been instantiated already, and we are now
+ -- creating the instance source for the corresponding body now,
+ -- retrieve the instance id that was assigned to the spec, which
+ -- corresponds to the same instantiation sloc.
+
+ Inst_Spec := Instance_Spec (Inst_Node);
+ if Present (Inst_Spec) then
+ declare
+ Inst_Spec_Ent : Entity_Id;
+ -- Instance spec entity
+
+ Inst_Spec_Sloc : Source_Ptr;
+ -- Virtual sloc of the spec instance source
+
+ Inst_Spec_Inst_Id : Instance_Id;
+ -- Instance id assigned to the instance spec
+
+ begin
+ Inst_Spec_Ent := Defining_Entity (Inst_Spec);
+
+ -- For a subprogram instantiation, we want the subprogram
+ -- instance, not the wrapper package.
+
+ if Present (Related_Instance (Inst_Spec_Ent)) then
+ Inst_Spec_Ent := Related_Instance (Inst_Spec_Ent);
+ end if;
+
+ -- The specification of the instance entity has a virtual
+ -- sloc within the instance sloc range.
+ -- ??? But the Unit_Declaration_Node has the sloc of the
+ -- instantiation, which is somewhat of an oddity.
+
+ Inst_Spec_Sloc :=
+ Sloc (Specification (Unit_Declaration_Node
+ (Inst_Spec_Ent)));
+ Inst_Spec_Inst_Id :=
+ Source_File.Table
+ (Get_Source_File_Index (Inst_Spec_Sloc)).Instance;
+
+ pragma Assert
+ (Sloc (Inst_Node) = Instances.Table (Inst_Spec_Inst_Id));
+ Snew.Instance := Inst_Spec_Inst_Id;
+ end;
- elsif Ekind (Template_Id) = E_Generic_Package then
- if Nkind (Dnod) = N_Package_Body then
- Write_Str ("body of package ");
else
- Write_Str ("spec of package ");
+ Instances.Append (Sloc (Inst_Node));
+ Snew.Instance := Instances.Last;
end if;
+ end if;
- elsif Ekind (Template_Id) = E_Function then
- Write_Str ("body of function ");
+ -- Now we need to compute the new values of Source_First,
+ -- Source_Last and adjust the source file pointer to have the
+ -- correct virtual origin for the new range of values.
- elsif Ekind (Template_Id) = E_Procedure then
- Write_Str ("body of procedure ");
+ Snew.Source_First := Source_File.Table (Xnew - 1).Source_Last + 1;
+ A.Adjust := Snew.Source_First - A.Lo;
+ Snew.Source_Last := A.Hi + A.Adjust;
- elsif Ekind (Template_Id) = E_Generic_Function then
- Write_Str ("spec of function ");
+ Set_Source_File_Index_Table (Xnew);
- elsif Ekind (Template_Id) = E_Generic_Procedure then
- Write_Str ("spec of procedure ");
+ Snew.Sloc_Adjust := Sold.Sloc_Adjust - A.Adjust;
- elsif Ekind (Template_Id) = E_Package_Body then
- Write_Str ("body of package ");
+ if Debug_Flag_L then
+ Write_Eol;
+ Write_Str ("*** Create instantiation source for ");
- else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
+ if Nkind (Dnod) in N_Proper_Body
+ and then Was_Originally_Stub (Dnod)
+ then
+ Write_Str ("subunit ");
- if Nkind (Dnod) = N_Procedure_Specification then
- Write_Str ("body of procedure ");
- else
+ elsif Ekind (Template_Id) = E_Generic_Package then
+ if Nkind (Dnod) = N_Package_Body then
+ Write_Str ("body of package ");
+ else
+ Write_Str ("spec of package ");
+ end if;
+
+ elsif Ekind (Template_Id) = E_Function then
Write_Str ("body of function ");
+
+ elsif Ekind (Template_Id) = E_Procedure then
+ Write_Str ("body of procedure ");
+
+ elsif Ekind (Template_Id) = E_Generic_Function then
+ Write_Str ("spec of function ");
+
+ elsif Ekind (Template_Id) = E_Generic_Procedure then
+ Write_Str ("spec of procedure ");
+
+ elsif Ekind (Template_Id) = E_Package_Body then
+ Write_Str ("body of package ");
+
+ else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
+
+ if Nkind (Dnod) = N_Procedure_Specification then
+ Write_Str ("body of procedure ");
+ else
+ Write_Str ("body of function ");
+ end if;
end if;
- end if;
- Write_Name (Chars (Template_Id));
- Write_Eol;
+ Write_Name (Chars (Template_Id));
+ Write_Eol;
- Write_Str (" new source index = ");
- Write_Int (Int (Xnew));
- Write_Eol;
+ Write_Str (" new source index = ");
+ Write_Int (Int (Xnew));
+ Write_Eol;
- Write_Str (" copying from file name = ");
- Write_Name (File_Name (Xold));
- Write_Eol;
+ Write_Str (" copying from file name = ");
+ Write_Name (File_Name (Xold));
+ Write_Eol;
- Write_Str (" old source index = ");
- Write_Int (Int (Xold));
- Write_Eol;
+ Write_Str (" old source index = ");
+ Write_Int (Int (Xold));
+ Write_Eol;
- Write_Str (" old lo = ");
- Write_Int (Int (A.Lo));
- Write_Eol;
+ Write_Str (" old lo = ");
+ Write_Int (Int (A.Lo));
+ Write_Eol;
- Write_Str (" old hi = ");
- Write_Int (Int (A.Hi));
- Write_Eol;
+ Write_Str (" old hi = ");
+ Write_Int (Int (A.Hi));
+ Write_Eol;
- Write_Str (" new lo = ");
- Write_Int (Int (Source_File.Table (Xnew).Source_First));
- Write_Eol;
+ Write_Str (" new lo = ");
+ Write_Int (Int (Snew.Source_First));
+ Write_Eol;
- Write_Str (" new hi = ");
- Write_Int (Int (Source_File.Table (Xnew).Source_Last));
- Write_Eol;
+ Write_Str (" new hi = ");
+ Write_Int (Int (Snew.Source_Last));
+ Write_Eol;
- Write_Str (" adjustment factor = ");
- Write_Int (Int (A.Adjust));
- Write_Eol;
+ Write_Str (" adjustment factor = ");
+ Write_Int (Int (A.Adjust));
+ Write_Eol;
- Write_Str (" instantiation location: ");
- Write_Location (Sloc (Inst_Node));
- Write_Eol;
- end if;
+ Write_Str (" instantiation location: ");
+ Write_Location (Sloc (Inst_Node));
+ Write_Eol;
+ end if;
- -- For a given character in the source, a higher subscript will be used
- -- to access the instantiation, which means that the virtual origin must
- -- have a corresponding lower value. We compute this new origin by
- -- taking the address of the appropriate adjusted element in the old
- -- array. Since this adjusted element will be at a negative subscript,
- -- we must suppress checks.
+ -- For a given character in the source, a higher subscript will be
+ -- used to access the instantiation, which means that the virtual
+ -- origin must have a corresponding lower value. We compute this new
+ -- origin by taking the address of the appropriate adjusted element
+ -- in the old array. Since this adjusted element will be at a
+ -- negative subscript, we must suppress checks.
- declare
- pragma Suppress (All_Checks);
+ declare
+ pragma Suppress (All_Checks);
- pragma Warnings (Off);
- -- This unchecked conversion is aliasing safe, since it is never used
- -- to create improperly aliased pointer values.
+ pragma Warnings (Off);
+ -- This unchecked conversion is aliasing safe, since it is never
+ -- used to create improperly aliased pointer values.
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ function To_Source_Buffer_Ptr is new
+ Unchecked_Conversion (Address, Source_Buffer_Ptr);
- pragma Warnings (On);
+ pragma Warnings (On);
- begin
- Source_File.Table (Xnew).Source_Text :=
- To_Source_Buffer_Ptr
- (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
+ begin
+ Snew.Source_Text :=
+ To_Source_Buffer_Ptr
+ (Sold.Source_Text (-A.Adjust)'Address);
+ end;
end;
end Create_Instantiation_Source;
Full_Debug_Name => Osint.Full_Source_Name,
Full_File_Name => Osint.Full_Source_Name,
Full_Ref_Name => Osint.Full_Source_Name,
+ Instance => No_Instance_Id,
Identifier_Casing => Unknown,
+ Inlined_Call => No_Location,
Inlined_Body => False,
- Instantiation => No_Location,
Keyword_Casing => Unknown,
Last_Source_Line => 1,
License => Unknown,
First_Time_Around := True;
Source_File.Init;
+
+ Instances.Init;
+ Instances.Append (No_Location);
+ pragma Assert (Instances.Last = No_Instance_Id);
end Initialize;
+ -------------------
+ -- Instantiation --
+ -------------------
+
+ function Instantiation (S : SFI) return Source_Ptr is
+ SIE : Source_File_Record renames Source_File.Table (S);
+ begin
+ if SIE.Inlined_Body then
+ return SIE.Inlined_Call;
+ else
+ return Instances.Table (SIE.Instance);
+ end if;
+ end Instantiation;
+
-------------------------
-- Instantiation_Depth --
-------------------------
return Instantiation (Get_Source_File_Index (S));
end Instantiation_Location;
+ --------------------------
+ -- Iterate_On_Instances --
+ --------------------------
+
+ procedure Iterate_On_Instances is
+ begin
+ for J in 1 .. Instances.Last loop
+ Process (J, Instances.Table (J));
+ end loop;
+ end Iterate_On_Instances;
+
----------------------
-- Last_Source_File --
----------------------
Tmp1 : Source_Buffer_Ptr;
begin
- if S.Instantiation /= No_Location then
+ if S.Instance /= No_Instance_Id then
null;
else
Source_Cache_First := 1;
Source_Cache_Last := 0;
- -- Read in source file table
+ -- Read in source file table and instance table
Source_File.Tree_Read;
+ Instances.Tree_Read;
-- The pointers we read in there for the source buffer and lines
-- table pointers are junk. We now read in the actual data that
-- we share the data for the generic template entry. Since the
-- template always occurs first, we can safely refer to its data.
- if S.Instantiation /= No_Location then
+ if S.Instance /= No_Instance_Id then
declare
ST : Source_File_Record renames
Source_File.Table (S.Template);
procedure Tree_Write is
begin
Source_File.Tree_Write;
+ Instances.Tree_Write;
-- The pointers we wrote out there for the source buffer and lines
-- table pointers are junk, we now write out the actual data that
-- shared with the generic template. When the tree is read, the
-- pointers must be set, but no extra data needs to be written.
- if S.Instantiation /= No_Location then
+ if S.Instance /= No_Instance_Id then
null;
-- For the normal case, write out the data of the tables
return Source_File.Table (S).Debug_Source_Name;
end Debug_Source_Name;
+ function Instance (S : SFI) return Instance_Id is
+ begin
+ return Source_File.Table (S).Instance;
+ end Instance;
+
function File_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).File_Name;
return Source_File.Table (S).Inlined_Body;
end Inlined_Body;
- function Instantiation (S : SFI) return Source_Ptr is
+ function Inlined_Call (S : SFI) return Source_Ptr is
begin
- return Source_File.Table (S).Instantiation;
- end Instantiation;
+ return Source_File.Table (S).Inlined_Call;
+ end Inlined_Call;
function Keyword_Casing (S : SFI) return Casing_Type is
begin
Preproc);
-- Source file with preprocessing commands to be preprocessed
+ type Instance_Id is new Nat;
+ No_Instance_Id : constant Instance_Id;
+
----------------------------
-- Source License Control --
----------------------------
-- Only processing in Sprint that generates this file is permitted to
-- set this field.
+ -- Instance : Instance_Id (read-only)
+ -- For entries corresponding to a generic instantiation, unique
+ -- identifier denoting the full chain of nested instantiations. Set to
+ -- No_Instance_Id for the case of a normal, non-instantiation entry.
+ -- See below for details on the handling of generic instantiations.
+
-- License : License_Type;
-- License status of source file
-- This value is used for formatting of error messages, and also is used
-- in the detection of keywords misused as identifiers.
- -- Instantiation : Source_Ptr;
- -- Source file location of the instantiation if this source file entry
- -- represents a generic instantiation. Set to No_Location for the case
- -- of a normal non-instantiation entry. See section below for details.
+ -- Inlined_Call : Source_Ptr;
+ -- Source file location of the subprogram call if this source file entry
+ -- represents an inlined body. Set to No_Location otherwise.
-- This field is read-only for clients.
-- Inlined_Body : Boolean;
-- This can only be set True if Instantiation has a value other than
-- No_Location. If true it indicates that the instantiation is actually
-- an instance of an inlined body.
+ -- ??? Redundant, always equal to (Inlined_Call /= No_Location)
-- Template : Source_File_Index; (read-only)
-- Source file index of the source file containing the template if this
function Full_Ref_Name (S : SFI) return File_Name_Type;
function Identifier_Casing (S : SFI) return Casing_Type;
function Inlined_Body (S : SFI) return Boolean;
- function Instantiation (S : SFI) return Source_Ptr;
+ function Inlined_Call (S : SFI) return Source_Ptr;
+ function Instance (S : SFI) return Instance_Id;
function Keyword_Casing (S : SFI) return Casing_Type;
function Last_Source_Line (S : SFI) return Physical_Line_Number;
function License (S : SFI) return License_Type;
-- to point to the same text, because of the virtual origin pointers used
-- in the source table.
- -- The Instantiation field of this source file index entry, usually set
- -- to No_Source_File, instead contains the Sloc of the instantiation. In
- -- the case of nested instantiations, this Sloc may itself refer to an
- -- instantiation, so the complete chain can be traced.
+ -- The Instantiation_Id field of this source file index entry, set
+ -- to No_Instance_Id for normal entries, instead contains a value that
+ -- uniquely identifies a particular instantiation, and the associated
+ -- entry in the Instances table. The source location of the instantiation
+ -- can be retrieved using function Instantiation below. In the case of
+ -- nested instantiations, the Instances table can be used to trace the
+ -- complete chain of nested instantiations.
- -- Two routines are used to build these special entries in the source
- -- file table. Create_Instantiation_Source is first called to build
+ -- Two routines are used to build the special instance entries in the
+ -- source file table. Create_Instantiation_Source is first called to build
-- the virtual source table entry for the instantiation, and then the
-- Sloc values in the copy are adjusted using Adjust_Instantiation_Sloc.
-- See child unit Sinput.L for details on these two routines.
+ generic
+ with procedure Process (Id : Instance_Id; Inst_Sloc : Source_Ptr);
+ procedure Iterate_On_Instances;
+ -- Execute Process for each entry in the instance table
+
+ function Instantiation (S : SFI) return Source_Ptr;
+ -- For a source file entry that represents an inlined body, source location
+ -- of the inlined call. Otherwise, for a source file entry that represents
+ -- a generic instantiation, source location of the instantiation. Returns
+ -- No_Location in all other cases.
+
-----------------
-- Global Data --
-----------------
private
pragma Inline (File_Name);
- pragma Inline (First_Mapped_Line);
pragma Inline (Full_File_Name);
- pragma Inline (Identifier_Casing);
- pragma Inline (Instantiation);
- pragma Inline (Keyword_Casing);
- pragma Inline (Last_Source_Line);
- pragma Inline (Last_Source_File);
+ pragma Inline (File_Type);
+ pragma Inline (Reference_Name);
+ pragma Inline (Full_Ref_Name);
+ pragma Inline (Debug_Source_Name);
+ pragma Inline (Full_Debug_Name);
+ pragma Inline (Instance);
pragma Inline (License);
pragma Inline (Num_SRef_Pragmas);
- pragma Inline (Num_Source_Files);
- pragma Inline (Num_Source_Lines);
- pragma Inline (Reference_Name);
- pragma Inline (Set_Keyword_Casing);
- pragma Inline (Set_Identifier_Casing);
+ pragma Inline (First_Mapped_Line);
+ pragma Inline (Source_Text);
pragma Inline (Source_First);
pragma Inline (Source_Last);
- pragma Inline (Source_Text);
- pragma Inline (Template);
pragma Inline (Time_Stamp);
+ pragma Inline (Source_Checksum);
+ pragma Inline (Last_Source_Line);
+ pragma Inline (Keyword_Casing);
+ pragma Inline (Identifier_Casing);
+ pragma Inline (Inlined_Call);
+ pragma Inline (Inlined_Body);
+ pragma Inline (Template);
+ pragma Inline (Unit);
+
+ pragma Inline (Set_Keyword_Casing);
+ pragma Inline (Set_Identifier_Casing);
+
+ pragma Inline (Last_Source_File);
+ pragma Inline (Num_Source_Files);
+ pragma Inline (Num_Source_Lines);
+
+ No_Instance_Id : constant Instance_Id := 0;
-------------------------
-- Source_Lines Tables --
Full_Debug_Name : File_Name_Type;
Full_File_Name : File_Name_Type;
Full_Ref_Name : File_Name_Type;
+ Instance : Instance_Id;
Num_SRef_Pragmas : Nat;
First_Mapped_Line : Logical_Line_Number;
Source_Text : Source_Buffer_Ptr;
Source_Last : Source_Ptr;
Source_Checksum : Word;
Last_Source_Line : Physical_Line_Number;
- Instantiation : Source_Ptr;
Template : Source_File_Index;
Unit : Unit_Number_Type;
Time_Stamp : Time_Stamp_Type;
File_Type : Type_Of_File;
+ Inlined_Call : Source_Ptr;
Inlined_Body : Boolean;
License : License_Type;
Keyword_Casing : Casing_Type;
Full_Debug_Name at 12 range 0 .. 31;
Full_File_Name at 16 range 0 .. 31;
Full_Ref_Name at 20 range 0 .. 31;
+ Instance at 48 range 0 .. 31;
Num_SRef_Pragmas at 24 range 0 .. 31;
First_Mapped_Line at 28 range 0 .. 31;
Source_First at 32 range 0 .. 31;
Source_Last at 36 range 0 .. 31;
Source_Checksum at 40 range 0 .. 31;
Last_Source_Line at 44 range 0 .. 31;
- Instantiation at 48 range 0 .. 31;
Template at 52 range 0 .. 31;
Unit at 56 range 0 .. 31;
Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1;
File_Type at 74 range 0 .. 7;
+ Inlined_Call at 88 range 0 .. 31;
Inlined_Body at 75 range 0 .. 7;
License at 76 range 0 .. 7;
Keyword_Casing at 77 range 0 .. 7;
-- The following fields are pointers, so we have to specialize their
-- lengths using pointer size, obtained above as Standard'Address_Size.
- Source_Text at 88 range 0 .. AS - 1;
- Lines_Table at 88 range AS .. AS * 2 - 1;
- Logical_Lines_Table at 88 range AS * 2 .. AS * 3 - 1;
+ Source_Text at 92 range 0 .. AS - 1;
+ Lines_Table at 92 range AS .. AS * 2 - 1;
+ Logical_Lines_Table at 92 range AS * 2 .. AS * 3 - 1;
end record;
- for Source_File_Record'Size use 88 * 8 + AS * 3;
+ for Source_File_Record'Size use 92 * 8 + AS * 3;
-- This ensures that we did not leave out any fields
package Source_File is new Table.Table (
Table_Increment => Alloc.Source_File_Increment,
Table_Name => "Source_File");
+ -- Auxiliary table containing source location of instantiations. Index 0
+ -- is used for code that does not come from an instance.
+
+ package Instances is new Table.Table (
+ Table_Component_Type => Source_Ptr,
+ Table_Index_Type => Instance_Id,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Source_File_Initial,
+ Table_Increment => Alloc.Source_File_Increment,
+ Table_Name => "Instances");
+
-----------------
-- Subprograms --
-----------------
* *
* C Header File *
* *
- * Copyright (C) 1992-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2012, 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- *
/* Used for Sloc in all nodes in the representation of package Standard. */
#define Standard_Location -2
+/* Instance identifiers */
+typedef Nat Instance_Id;
+
/* Type used for union of all possible ID values covering all ranges */
typedef int Union_Id;
projects / platform / upstream / gcc.git / commitdiff