OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r191904
This commit is contained in:
Arnaud Charlet 2012-10-01 11:21:46 +02:00
parent d85be3ba3b
commit cf427f02bb
21 changed files with 580 additions and 229 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
gcc/ada/ChangeLog
View File

@ -1,3 +1,57 @@
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.

8
gcc/ada/back_end.adb
View File

@ -76,6 +76,7 @@ package body Back_End is
type File_Info_Type is record
File_Name : File_Name_Type;
Instance : Instance_Id;
Num_Source_Lines : Nat;
end record;
@ -119,6 +120,7 @@ package body Back_End is
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;
@ -243,6 +245,12 @@ package body Back_End is
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;

7
gcc/ada/checks.adb
View File

@ -4599,6 +4599,13 @@ package body Checks is
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.

2
gcc/ada/exp_ch3.adb
View File

@ -659,7 +659,7 @@ package body Exp_Ch3 is
-- 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

3
gcc/ada/gcc-interface/gigi.h
View File

@ -228,7 +228,8 @@ extern const char *ref_filename;
struct File_Info_Type
{
File_Name_Type File_Name;
Nat Num_Source_Lines;
Instance_Id Instance;
Nat Num_Source_Lines;
};
#ifdef __cplusplus

8
gcc/ada/gcc-interface/trans.c
View File

@ -293,6 +293,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
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;
@ -325,7 +326,12 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
/* 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);

79
gcc/ada/get_scos.adb
View File

@ -225,7 +225,7 @@ begin
case C is
-- Header entry
-- Header or instance table entry
when ' ' =>
@ -236,26 +236,71 @@ begin
SCO_Table.Last;
end if;
-- Scan out dependency number and file name
Skip_Spaces;
Dnum := Get_Int;
Skip_Spaces;
N := 0;
while Nextc > ' ' loop
N := N + 1;
Buf (N) := Getc;
end loop;
case Nextc is
-- Make new unit table entry (will fill in To later)
-- Instance table entry
SCO_Unit_Table.Append (
(File_Name => new String'(Buf (1 .. N)),
Dep_Num => Dnum,
From => SCO_Table.Last + 1,
To => 0));
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;
-- 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;
end case;
-- Statement entry

11
gcc/ada/opt.ads
View File

@ -648,9 +648,14 @@ package Opt is
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

62
gcc/ada/par_sco.adb
View File

@ -102,6 +102,9 @@ package body Par_SCO is
-- 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;
@ -138,6 +141,9 @@ package body Par_SCO is
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;
@ -696,16 +702,37 @@ package body Par_SCO is
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
@ -949,26 +976,6 @@ package body Par_SCO is
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,
@ -980,6 +987,21 @@ package body Par_SCO is
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 --
-----------------------------------------

6
gcc/ada/par_sco.ads
View File

@ -61,9 +61,9 @@ package Par_SCO is
-- 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

35
gcc/ada/put_scos.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Opt; use Opt;
with Par_SCO; use Par_SCO;
with SCOs; use SCOs;
with Snames; use Snames;
@ -34,6 +35,9 @@ procedure Put_SCOs is
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
@ -76,6 +80,33 @@ procedure Put_SCOs is
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 --
------------------------
@ -270,4 +301,8 @@ begin
end loop;
end;
end loop;
if Opt.Generate_SCO_Instance_Table then
Write_Instance_Table;
end if;
end Put_SCOs;

4
gcc/ada/s-gearop.adb
View File

@ -902,7 +902,7 @@ package body System.Generic_Array_Operations is
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;
@ -913,7 +913,7 @@ package body System.Generic_Array_Operations is
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;

3
gcc/ada/scos.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -33,6 +33,7 @@ package body SCOs is
begin
SCO_Table.Init;
SCO_Unit_Table.Init;
SCO_Instance_Table.Init;
-- Set dummy zeroth entry for sort routine, real entries start at 1

71
gcc/ada/scos.ads
View File

@ -246,7 +246,7 @@ package SCOs is
-- 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:
@ -308,35 +308,6 @@ package SCOs is
-- 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
@ -360,6 +331,19 @@ package SCOs is
-- 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
@ -471,12 +455,6 @@ package SCOs is
-- 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.
@ -515,6 +493,27 @@ package SCOs is
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 --
-----------------

9
gcc/ada/sem_ch3.adb
View File

@ -2152,7 +2152,9 @@ package body Sem_Ch3 is
-- 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
@ -2168,6 +2170,11 @@ package body Sem_Ch3 is
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);

17
gcc/ada/sem_elab.adb
View File

@ -153,7 +153,7 @@ package body Sem_Elab is
-- 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 --
@ -1162,8 +1162,6 @@ package body Sem_Elab is
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
@ -1206,10 +1204,17 @@ package body Sem_Elab is
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;

5
gcc/ada/sinput-c.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -178,9 +178,10 @@ package body Sinput.C is
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,

261
gcc/ada/sinput-l.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -38,6 +38,8 @@ with Prep; use Prep;
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;
@ -138,127 +140,191 @@ package body Sinput.L is
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 ");
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 ");
Instances.Append (Sloc (Inst_Node));
Snew.Instance := Instances.Last;
end if;
end if;
Write_Name (Chars (Template_Id));
Write_Eol;
-- 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.
Write_Str (" new source index = ");
Write_Int (Int (Xnew));
Write_Eol;
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;
Write_Str (" copying from file name = ");
Write_Name (File_Name (Xold));
Write_Eol;
Set_Source_File_Index_Table (Xnew);
Write_Str (" old source index = ");
Write_Int (Int (Xold));
Write_Eol;
Snew.Sloc_Adjust := Sold.Sloc_Adjust - A.Adjust;
Write_Str (" old lo = ");
Write_Int (Int (A.Lo));
Write_Eol;
if Debug_Flag_L then
Write_Eol;
Write_Str ("*** Create instantiation source for ");
Write_Str (" old hi = ");
Write_Int (Int (A.Hi));
Write_Eol;
if Nkind (Dnod) in N_Proper_Body
and then Was_Originally_Stub (Dnod)
then
Write_Str ("subunit ");
Write_Str (" new lo = ");
Write_Int (Int (Source_File.Table (Xnew).Source_First));
Write_Eol;
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;
Write_Str (" new hi = ");
Write_Int (Int (Source_File.Table (Xnew).Source_Last));
Write_Eol;
elsif Ekind (Template_Id) = E_Function then
Write_Str ("body of function ");
Write_Str (" adjustment factor = ");
Write_Int (Int (A.Adjust));
Write_Eol;
elsif Ekind (Template_Id) = E_Procedure then
Write_Str ("body of procedure ");
Write_Str (" instantiation location: ");
Write_Location (Sloc (Inst_Node));
Write_Eol;
end if;
elsif Ekind (Template_Id) = E_Generic_Function then
Write_Str ("spec of function ");
-- 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.
elsif Ekind (Template_Id) = E_Generic_Procedure then
Write_Str ("spec of procedure ");
declare
pragma Suppress (All_Checks);
elsif Ekind (Template_Id) = E_Package_Body then
Write_Str ("body of package ");
pragma Warnings (Off);
-- This unchecked conversion is aliasing safe, since it is never used
-- to create improperly aliased pointer values.
else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
if Nkind (Dnod) = N_Procedure_Specification then
Write_Str ("body of procedure ");
else
Write_Str ("body of function ");
end if;
end if;
pragma Warnings (On);
Write_Name (Chars (Template_Id));
Write_Eol;
begin
Source_File.Table (Xnew).Source_Text :=
To_Source_Buffer_Ptr
(Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
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 (" old source index = ");
Write_Int (Int (Xold));
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 (" new lo = ");
Write_Int (Int (Snew.Source_First));
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 (" 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.
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.
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
pragma Warnings (On);
begin
Snew.Source_Text :=
To_Source_Buffer_Ptr
(Sold.Source_Text (-A.Adjust)'Address);
end;
end;
end Create_Instantiation_Source;
@ -433,9 +499,10 @@ package body Sinput.L is
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,

50
gcc/ada/sinput.adb
View File

@ -477,8 +477,26 @@ package body Sinput is
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 --
-------------------------
@ -511,6 +529,17 @@ package body Sinput is
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 --
----------------------
@ -852,7 +881,7 @@ package body Sinput is
Tmp1 : Source_Buffer_Ptr;
begin
if S.Instantiation /= No_Location then
if S.Instance /= No_Instance_Id then
null;
else
@ -887,9 +916,10 @@ package body Sinput is
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
@ -904,7 +934,7 @@ package body Sinput is
-- 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);
@ -1004,6 +1034,7 @@ package body Sinput is
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
@ -1018,7 +1049,7 @@ package body Sinput is
-- 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
@ -1131,6 +1162,11 @@ package body Sinput is
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;
@ -1171,10 +1207,10 @@ package body Sinput is
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

109
gcc/ada/sinput.ads
View File

@ -83,6 +83,9 @@ package Sinput is
Preproc);
-- Source file with preprocessing commands to be preprocessed
type Instance_Id is new Nat;
No_Instance_Id : constant Instance_Id;
----------------------------
-- Source License Control --
----------------------------
@ -198,6 +201,12 @@ package Sinput is
-- 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
@ -249,16 +258,16 @@ package Sinput is
-- 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
@ -289,7 +298,8 @@ package Sinput is
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;
@ -408,17 +418,31 @@ package Sinput is
-- 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 --
-----------------
@ -722,25 +746,37 @@ package Sinput is
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 --
@ -781,6 +817,7 @@ private
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;
@ -788,11 +825,11 @@ private
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;
@ -839,17 +876,18 @@ private
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;
@ -860,12 +898,12 @@ private
-- 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 (
@ -876,6 +914,17 @@ private
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 --
-----------------

5
gcc/ada/types.h
View File

@ -6,7 +6,7 @@
* *
* 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- *
@ -130,6 +130,9 @@ typedef Text_Ptr Source_Ptr;
/* 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;