Skip to content

R
riscv-gcc-1
Commit 88a27b18 by Arnaud Charlet
Options

[multiple changes] 

2012-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch12.adb (Analyze_Associations): Alphabetize local variables and
	constants. Rename Actual_Types to Actuals_To_Freeze. Rename Next_Formal
	to Saved_Formal.
	Freeze all eligible subprograms which appear as actuals in
	the instantiation.
	(Has_Fully_Defined_Profile): New routine.
	(Renames_Standard_Subprogram): New routine.
	(Earlier): Add local variable N. Comment update. Do not use source
	locations when trying to determine whether one node precedes another.

2012-01-23  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch4.adb (Expand_Concatenate): In the case
	where the result of a concatentation can be null, set the to
	result have both the low and high bounds of the right operand (not
	just the high bound, as was the case prior to this fix). Also,
	fix the saved high bound setting (Last_Opnd_High_Bound) in the
	empty string literal case (should have been low bound minus one,
	rather than plus one).

2012-01-23  Thomas Quinot  <quinot@adacore.com>

	* scos.ads, put_scos.adb, get_scos.adb (Get_SCOs, Put_SCOs): Do not
	omit statement SCOs for disabled pragmas.

From-SVN: r183419
parent 3c24c853
Showing with 318 additions and 65 deletions
gcc/ada/ChangeLog
2012-01-23 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch12.adb (Analyze_Associations): Alphabetize local variables and
constants. Rename Actual_Types to Actuals_To_Freeze. Rename Next_Formal
to Saved_Formal.
Freeze all eligible subprograms which appear as actuals in
the instantiation.
(Has_Fully_Defined_Profile): New routine.
(Renames_Standard_Subprogram): New routine.
(Earlier): Add local variable N. Comment update. Do not use source
locations when trying to determine whether one node precedes another.
2012-01-23 Gary Dismukes <dismukes@adacore.com>
* exp_ch4.adb (Expand_Concatenate): In the case
where the result of a concatentation can be null, set the to
result have both the low and high bounds of the right operand (not
just the high bound, as was the case prior to this fix). Also,
fix the saved high bound setting (Last_Opnd_High_Bound) in the
empty string literal case (should have been low bound minus one,
rather than plus one).
2012-01-23 Thomas Quinot <quinot@adacore.com>
* scos.ads, put_scos.adb, get_scos.adb (Get_SCOs, Put_SCOs): Do not
omit statement SCOs for disabled pragmas.
2012-01-23 Matthew Heaney <heaney@adacore.com> 2012-01-23 Matthew Heaney <heaney@adacore.com>
* a-cohase.ads, a-cihase.ads, a-cbhase.ads, a-coorse.ads, * a-cohase.ads, a-cihase.ads, a-cbhase.ads, a-coorse.ads,
......
gcc/ada/exp_ch4.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2601,6 +2601,12 @@ package body Exp_Ch4 is ...@@ -2601,6 +2601,12 @@ package body Exp_Ch4 is
-- This is either an integer literal node, or an identifier reference to -- This is either an integer literal node, or an identifier reference to
-- a constant entity initialized to the appropriate value. -- a constant entity initialized to the appropriate value.
Last_Opnd_Low_Bound : Node_Id;
-- A tree node representing the low bound of the last operand. This
-- need only be set if the result could be null. It is used for the
-- special case of setting the right low bound for a null result.
-- This is of type Ityp.
Last_Opnd_High_Bound : Node_Id; Last_Opnd_High_Bound : Node_Id;
-- A tree node representing the high bound of the last operand. This -- A tree node representing the high bound of the last operand. This
-- need only be set if the result could be null. It is used for the -- need only be set if the result could be null. It is used for the
...@@ -2811,11 +2817,14 @@ package body Exp_Ch4 is ...@@ -2811,11 +2817,14 @@ package body Exp_Ch4 is
Result_May_Be_Null := False; Result_May_Be_Null := False;
end if; end if;
-- Capture last operand high bound if result could be null -- Capture last operand low and high bound if result could be null
if J = N and then Result_May_Be_Null then if J = N and then Result_May_Be_Null then
Last_Opnd_Low_Bound :=
New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
Last_Opnd_High_Bound := Last_Opnd_High_Bound :=
Make_Op_Add (Loc, Make_Op_Subtract (Loc,
Left_Opnd => Left_Opnd =>
New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)), New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
Right_Opnd => Make_Integer_Literal (Loc, 1)); Right_Opnd => Make_Integer_Literal (Loc, 1));
...@@ -2871,9 +2880,13 @@ package body Exp_Ch4 is ...@@ -2871,9 +2880,13 @@ package body Exp_Ch4 is
Result_May_Be_Null := False; Result_May_Be_Null := False;
end if; end if;
-- Capture last operand bound if result could be null -- Capture last operand bounds if result could be null
if J = N and then Result_May_Be_Null then if J = N and then Result_May_Be_Null then
Last_Opnd_Low_Bound :=
Convert_To (Ityp,
Make_Integer_Literal (Loc, Expr_Value (Lo)));
Last_Opnd_High_Bound := Last_Opnd_High_Bound :=
Convert_To (Ityp, Convert_To (Ityp,
Make_Integer_Literal (Loc, Expr_Value (Hi))); Make_Integer_Literal (Loc, Expr_Value (Hi)));
...@@ -2914,7 +2927,16 @@ package body Exp_Ch4 is ...@@ -2914,7 +2927,16 @@ package body Exp_Ch4 is
Duplicate_Subexpr (Opnd, Name_Req => True), Duplicate_Subexpr (Opnd, Name_Req => True),
Attribute_Name => Name_First); Attribute_Name => Name_First);
-- Capture last operand bounds if result could be null
if J = N and Result_May_Be_Null then if J = N and Result_May_Be_Null then
Last_Opnd_Low_Bound :=
Convert_To (Ityp,
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr (Opnd, Name_Req => True),
Attribute_Name => Name_First));
Last_Opnd_High_Bound := Last_Opnd_High_Bound :=
Convert_To (Ityp, Convert_To (Ityp,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
...@@ -3124,6 +3146,15 @@ package body Exp_Ch4 is ...@@ -3124,6 +3146,15 @@ package body Exp_Ch4 is
-- bounds if the last operand is super-flat). -- bounds if the last operand is super-flat).
if Result_May_Be_Null then if Result_May_Be_Null then
Low_Bound :=
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => New_Copy (Aggr_Length (NN)),
Right_Opnd => Make_Artyp_Literal (0)),
Last_Opnd_Low_Bound,
Low_Bound));
High_Bound := High_Bound :=
Make_Conditional_Expression (Loc, Make_Conditional_Expression (Loc,
Expressions => New_List ( Expressions => New_List (
......
gcc/ada/get_scos.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -301,7 +301,7 @@ begin ...@@ -301,7 +301,7 @@ begin
when others => when others =>
Skipc; Skipc;
if Typ = 'P' then if Typ = 'P' or else Typ = 'p' then
if Nextc not in '1' .. '9' then if Nextc not in '1' .. '9' then
N := 1; N := 1;
loop loop
......
gcc/ada/put_scos.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -139,12 +139,6 @@ begin ...@@ -139,12 +139,6 @@ begin
Ctr := 0; Ctr := 0;
Continuation := False; Continuation := False;
loop loop
if SCO_Pragma_Disabled
(SCO_Table.Table (Start).Pragma_Sloc)
then
goto Next_Statement;
end if;
if Ctr = 0 then if Ctr = 0 then
Write_SCO_Initiate (U); Write_SCO_Initiate (U);
if not Continuation then if not Continuation then
...@@ -169,7 +163,7 @@ begin ...@@ -169,7 +163,7 @@ begin
Write_Info_Char (Sent.C2); Write_Info_Char (Sent.C2);
if Sent.C1 = 'S' if Sent.C1 = 'S'
and then Sent.C2 = 'P' and then (Sent.C2 = 'P' or else Sent.C2 = 'p')
and then Sent.Pragma_Name /= Unknown_Pragma and then Sent.Pragma_Name /= Unknown_Pragma
then then
-- Strip leading "PRAGMA_" -- Strip leading "PRAGMA_"
...@@ -205,7 +199,6 @@ begin ...@@ -205,7 +199,6 @@ begin
Ctr := 0; Ctr := 0;
end if; end if;
<<Next_Statement>>
exit when SCO_Table.Table (Start).Last; exit when SCO_Table.Table (Start).Last;
Start := Start + 1; Start := Start + 1;
end loop; end loop;
......
gcc/ada/scos.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -157,6 +157,7 @@ package SCOs is ...@@ -157,6 +157,7 @@ package SCOs is
-- F FOR loop (from FOR through end of iteration scheme) -- F FOR loop (from FOR through end of iteration scheme)
-- I IF statement (from IF through end of condition) -- I IF statement (from IF through end of condition)
-- P[name:] PRAGMA with the indicated name -- P[name:] PRAGMA with the indicated name
-- p[name:] disabled PRAGMA with the indicated name
-- R extended RETURN statement -- R extended RETURN statement
-- W WHILE loop statement (from WHILE through end of condition) -- W WHILE loop statement (from WHILE through end of condition)
......
gcc/ada/sem_ch12.adb
...@@ -917,20 +917,20 @@ package body Sem_Ch12 is ...@@ -917,20 +917,20 @@ package body Sem_Ch12 is
Formals : List_Id; Formals : List_Id;
F_Copy : List_Id) return List_Id F_Copy : List_Id) return List_Id
is is
Actual_Types : constant Elist_Id := New_Elmt_List; Actuals_To_Freeze : constant Elist_Id := New_Elmt_List;
Assoc : constant List_Id := New_List; Assoc : constant List_Id := New_List;
Default_Actuals : constant Elist_Id := New_Elmt_List; Default_Actuals : constant Elist_Id := New_Elmt_List;
Gen_Unit : constant Entity_Id := Gen_Unit : constant Entity_Id :=
Defining_Entity (Parent (F_Copy)); Defining_Entity (Parent (F_Copy));
Actuals : List_Id; Actuals : List_Id;
Actual : Node_Id; Actual : Node_Id;
Formal : Node_Id;
Next_Formal : Node_Id;
Analyzed_Formal : Node_Id; Analyzed_Formal : Node_Id;
First_Named : Node_Id := Empty;
Formal : Node_Id;
Match : Node_Id; Match : Node_Id;
Named : Node_Id; Named : Node_Id;
First_Named : Node_Id := Empty; Saved_Formal : Node_Id;
Default_Formals : constant List_Id := New_List; Default_Formals : constant List_Id := New_List;
-- If an Others_Choice is present, some of the formals may be defaulted. -- If an Others_Choice is present, some of the formals may be defaulted.
...@@ -958,6 +958,10 @@ package body Sem_Ch12 is ...@@ -958,6 +958,10 @@ package body Sem_Ch12 is
-- to formals of formal packages by AI05-0025, and it also applies to -- to formals of formal packages by AI05-0025, and it also applies to
-- box-initialized formals. -- box-initialized formals.
function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean;
-- Determine whether the parameter types and the return type of Subp
-- are fully defined at the point of instantiation.
function Matching_Actual function Matching_Actual
(F : Entity_Id; (F : Entity_Id;
A_F : Entity_Id) return Node_Id; A_F : Entity_Id) return Node_Id;
...@@ -966,7 +970,7 @@ package body Sem_Ch12 is ...@@ -966,7 +970,7 @@ package body Sem_Ch12 is
-- are named, scan the parameter associations to find the right one. -- are named, scan the parameter associations to find the right one.
-- A_F is the corresponding entity in the analyzed generic,which is -- A_F is the corresponding entity in the analyzed generic,which is
-- placed on the selector name for ASIS use. -- placed on the selector name for ASIS use.
--
-- In Ada 2005, a named association may be given with a box, in which -- In Ada 2005, a named association may be given with a box, in which
-- case Matching_Actual sets Found_Assoc to the generic association, -- case Matching_Actual sets Found_Assoc to the generic association,
-- but return Empty for the actual itself. In this case the code below -- but return Empty for the actual itself. In this case the code below
...@@ -982,6 +986,10 @@ package body Sem_Ch12 is ...@@ -982,6 +986,10 @@ package body Sem_Ch12 is
-- associations, and add an explicit box association for F if there -- associations, and add an explicit box association for F if there
-- is none yet, and the default comes from an Others_Choice. -- is none yet, and the default comes from an Others_Choice.
function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean;
-- Determine whether Subp renames one of the subprograms defined in the
-- generated package Standard.
procedure Set_Analyzed_Formal; procedure Set_Analyzed_Formal;
-- Find the node in the generic copy that corresponds to a given formal. -- Find the node in the generic copy that corresponds to a given formal.
-- The semantic information on this node is used to perform legality -- The semantic information on this node is used to perform legality
...@@ -1025,6 +1033,62 @@ package body Sem_Ch12 is ...@@ -1025,6 +1033,62 @@ package body Sem_Ch12 is
end loop; end loop;
end Check_Overloaded_Formal_Subprogram; end Check_Overloaded_Formal_Subprogram;
-------------------------------
-- Has_Fully_Defined_Profile --
-------------------------------
function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is
function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean;
-- Determine whethet type Typ is fully defined
---------------------------
-- Is_Fully_Defined_Type --
---------------------------
function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is
begin
-- A private type without a full view is not fully defined
if Is_Private_Type (Typ)
and then No (Full_View (Typ))
then
return False;
-- An incomplete type is never fully defined
elsif Is_Incomplete_Type (Typ) then
return False;
-- All other types are fully defined
else
return True;
end if;
end Is_Fully_Defined_Type;
-- Local declarations
Param : Entity_Id;
-- Start of processing for Has_Fully_Defined_Profile
begin
-- Check the parameters
Param := First_Formal (Subp);
while Present (Param) loop
if not Is_Fully_Defined_Type (Etype (Param)) then
return False;
end if;
Next_Formal (Param);
end loop;
-- Check the return type
return Is_Fully_Defined_Type (Etype (Subp));
end Has_Fully_Defined_Profile;
--------------------- ---------------------
-- Matching_Actual -- -- Matching_Actual --
--------------------- ---------------------
...@@ -1149,6 +1213,26 @@ package body Sem_Ch12 is ...@@ -1149,6 +1213,26 @@ package body Sem_Ch12 is
end if; end if;
end Process_Default; end Process_Default;
---------------------------------
-- Renames_Standard_Subprogram --
---------------------------------
function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is
Id : Entity_Id;
begin
Id := Alias (Subp);
while Present (Id) loop
if Scope (Id) = Standard_Standard then
return True;
end if;
Id := Alias (Id);
end loop;
return False;
end Renames_Standard_Subprogram;
------------------------- -------------------------
-- Set_Analyzed_Formal -- -- Set_Analyzed_Formal --
------------------------- -------------------------
...@@ -1259,7 +1343,7 @@ package body Sem_Ch12 is ...@@ -1259,7 +1343,7 @@ package body Sem_Ch12 is
Named := First_Named; Named := First_Named;
while Present (Named) loop while Present (Named) loop
if Nkind (Named) /= N_Others_Choice if Nkind (Named) /= N_Others_Choice
and then No (Selector_Name (Named)) and then No (Selector_Name (Named))
then then
Error_Msg_N ("invalid positional actual after named one", Named); Error_Msg_N ("invalid positional actual after named one", Named);
Abandon_Instantiation (Named); Abandon_Instantiation (Named);
...@@ -1293,7 +1377,7 @@ package body Sem_Ch12 is ...@@ -1293,7 +1377,7 @@ package body Sem_Ch12 is
while Present (Formal) loop while Present (Formal) loop
Set_Analyzed_Formal; Set_Analyzed_Formal;
Next_Formal := Next_Non_Pragma (Formal); Saved_Formal := Next_Non_Pragma (Formal);
case Nkind (Formal) is case Nkind (Formal) is
when N_Formal_Object_Declaration => when N_Formal_Object_Declaration =>
...@@ -1335,19 +1419,24 @@ package body Sem_Ch12 is ...@@ -1335,19 +1419,24 @@ package body Sem_Ch12 is
Analyze (Match); Analyze (Match);
Append_List Append_List
(Instantiate_Type (Instantiate_Type
(Formal, Match, Analyzed_Formal, Assoc), (Formal, Match, Analyzed_Formal, Assoc),
Assoc); Assoc);
-- An instantiation is a freeze point for the actuals, -- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package, or the -- unless this is a rewritten formal package, or the
-- formal is an Ada 2012 formal incomplete type. -- formal is an Ada 2012 formal incomplete type.
if Nkind (I_Node) /= N_Formal_Package_Declaration if Nkind (I_Node) = N_Formal_Package_Declaration
and then or else
Ekind (Defining_Identifier (Analyzed_Formal)) /= (Ada_Version >= Ada_2012
E_Incomplete_Type and then
Ekind (Defining_Identifier (Analyzed_Formal)) =
E_Incomplete_Type)
then then
Append_Elmt (Entity (Match), Actual_Types); null;
else
Append_Elmt (Entity (Match), Actuals_To_Freeze);
end if; end if;
end if; end if;
...@@ -1364,9 +1453,9 @@ package body Sem_Ch12 is ...@@ -1364,9 +1453,9 @@ package body Sem_Ch12 is
when N_Formal_Subprogram_Declaration => when N_Formal_Subprogram_Declaration =>
Match := Match :=
Matching_Actual ( Matching_Actual
Defining_Unit_Name (Specification (Formal)), (Defining_Unit_Name (Specification (Formal)),
Defining_Unit_Name (Specification (Analyzed_Formal))); Defining_Unit_Name (Specification (Analyzed_Formal)));
-- If the formal subprogram has the same name as another -- If the formal subprogram has the same name as another
-- formal subprogram of the generic, then a named -- formal subprogram of the generic, then a named
...@@ -1384,10 +1473,9 @@ package body Sem_Ch12 is ...@@ -1384,10 +1473,9 @@ package body Sem_Ch12 is
-- partial parametrization, or else the formal has a default -- partial parametrization, or else the formal has a default
-- or a box. -- or a box.
if No (Match) if No (Match) and then Partial_Parametrization then
and then Partial_Parametrization
then
Process_Default (Formal); Process_Default (Formal);
if Nkind (I_Node) = N_Formal_Package_Declaration then if Nkind (I_Node) = N_Formal_Package_Declaration then
Check_Overloaded_Formal_Subprogram (Formal); Check_Overloaded_Formal_Subprogram (Formal);
end if; end if;
...@@ -1396,6 +1484,37 @@ package body Sem_Ch12 is ...@@ -1396,6 +1484,37 @@ package body Sem_Ch12 is
Append_To (Assoc, Append_To (Assoc,
Instantiate_Formal_Subprogram Instantiate_Formal_Subprogram
(Formal, Match, Analyzed_Formal)); (Formal, Match, Analyzed_Formal));
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package.
if Nkind (I_Node) /= N_Formal_Package_Declaration
and then Nkind (Match) = N_Identifier
and then Is_Subprogram (Entity (Match))
-- The actual subprogram may rename a routine defined
-- in Standard. Avoid freezing such renamings because
-- subprograms coming from Standard cannot be frozen.
and then
not Renames_Standard_Subprogram (Entity (Match))
-- If the actual subprogram comes from a different
-- unit, it is already frozen, either by a body in
-- that unit or by the end of the declarative part
-- of the unit. This check avoids the freezing of
-- subprograms defined in Standard which are used
-- as generic actuals.
and then In_Same_Code_Unit (Entity (Match), I_Node)
and then Has_Fully_Defined_Profile (Entity (Match))
then
-- Mark the subprogram as having a delayed freeze
-- since this may be an out-of-order action.
Set_Has_Delayed_Freeze (Entity (Match));
Append_Elmt (Entity (Match), Actuals_To_Freeze);
end if;
end if; end if;
-- If this is a nested generic, preserve default for later -- If this is a nested generic, preserve default for later
...@@ -1459,7 +1578,7 @@ package body Sem_Ch12 is ...@@ -1459,7 +1578,7 @@ package body Sem_Ch12 is
end case; end case;
Formal := Next_Formal; Formal := Saved_Formal;
Next_Non_Pragma (Analyzed_Formal); Next_Non_Pragma (Analyzed_Formal);
end loop; end loop;
...@@ -1484,8 +1603,12 @@ package body Sem_Ch12 is ...@@ -1484,8 +1603,12 @@ package body Sem_Ch12 is
("too many actuals in generic instantiation", Instantiation_Node); ("too many actuals in generic instantiation", Instantiation_Node);
end if; end if;
-- An instantiation freezes all generic actuals. The only exceptions
-- to this are incomplete types and subprograms which are not fully
-- defined at the point of instantiation.
declare declare
Elmt : Elmt_Id := First_Elmt (Actual_Types); Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze);
begin begin
while Present (Elmt) loop while Present (Elmt) loop
Freeze_Before (I_Node, Node (Elmt)); Freeze_Before (I_Node, Node (Elmt));
...@@ -6818,11 +6941,6 @@ package body Sem_Ch12 is ...@@ -6818,11 +6941,6 @@ package body Sem_Ch12 is
------------- -------------
function Earlier (N1, N2 : Node_Id) return Boolean is function Earlier (N1, N2 : Node_Id) return Boolean is
D1 : Integer := 0;
D2 : Integer := 0;
P1 : Node_Id := N1;
P2 : Node_Id := N2;
procedure Find_Depth (P : in out Node_Id; D : in out Integer); procedure Find_Depth (P : in out Node_Id; D : in out Integer);
-- Find distance from given node to enclosing compilation unit -- Find distance from given node to enclosing compilation unit
...@@ -6840,6 +6958,13 @@ package body Sem_Ch12 is ...@@ -6840,6 +6958,13 @@ package body Sem_Ch12 is
end loop; end loop;
end Find_Depth; end Find_Depth;
-- Local declarations
D1 : Integer := 0;
D2 : Integer := 0;
P1 : Node_Id := N1;
P2 : Node_Id := N2;
-- Start of processing for Earlier -- Start of processing for Earlier
begin begin
...@@ -6864,12 +6989,11 @@ package body Sem_Ch12 is ...@@ -6864,12 +6989,11 @@ package body Sem_Ch12 is
end loop; end loop;
-- At this point P1 and P2 are at the same distance from the root. -- At this point P1 and P2 are at the same distance from the root.
-- We examine their parents until we find a common declarative list, -- We examine their parents until we find a common declarative list.
-- at which point we can establish their relative placement by -- If we reach the root, N1 and N2 do not descend from the same
-- comparing their ultimate slocs. If we reach the root, N1 and N2 -- declarative list (e.g. one is nested in the declarative part and
-- do not descend from the same declarative list (e.g. one is nested -- the other is in a block in the statement part) and the earlier
-- in the declarative part and the other is in a block in the -- one is already frozen.
-- statement part) and the earlier one is already frozen.
while not Is_List_Member (P1) while not Is_List_Member (P1)
or else not Is_List_Member (P2) or else not Is_List_Member (P2)
...@@ -6891,22 +7015,99 @@ package body Sem_Ch12 is ...@@ -6891,22 +7015,99 @@ package body Sem_Ch12 is
end if; end if;
end loop; end loop;
-- If the sloc positions are different the result is unambiguous. If -- Expanded code usually shares the source location of the original
-- the slocs are identical, one of them must not come from source, which -- construct it was generated for. This however may not necessarely
-- is the case for freeze nodes, whose sloc is unrelated to the point -- reflect the true location of the code within the tree.
-- point at which they are inserted in the tree. The source node is the
-- earlier one in the tree.
if Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)) then -- Before comparing the slocs of the two nodes, make sure that we are
return True; -- working with correct source locations. Assume that P1 is to the left
-- of P2. If either one does not come from source, traverse the common
-- list heading towards the other node and locate the first source
-- statement.
elsif -- P1 P2
Top_Level_Location (Sloc (P1)) > Top_Level_Location (Sloc (P2)) -- ----+===+===+--------------+===+===+----
then -- expanded code expanded code
return False;
if not Comes_From_Source (P1) then
while Present (P1) loop
-- Neither P2 nor a source statement were located during the
-- search. If we reach the end of the list, then P1 does not
-- occur earlier than P2.
-- ---->
-- start --- P2 ----- P1 --- end
if No (Next (P1)) then
return False;
-- We encounter P2 while going to the right of the list. This
-- means that P1 does indeed appear earlier.
-- ---->
-- start --- P1 ===== P2 --- end
-- expanded code in between
elsif P1 = P2 then
return True;
-- No need to look any further since we have located a source
-- statement.
elsif Comes_From_Source (P1) then
exit;
end if;
-- Keep going right
Next (P1);
end loop;
end if;
if not Comes_From_Source (P2) then
while Present (P2) loop
-- Neither P1 nor a source statement were located during the
-- search. If we reach the start of the list, then P1 does not
-- occur earlier than P2.
-- <----
-- start --- P2 --- P1 --- end
if No (Prev (P2)) then
return False;
-- We encounter P1 while going to the left of the list. This
-- means that P1 does indeed appear earlier.
-- <----
-- start --- P1 ===== P2 --- end
-- expanded code in between
elsif P2 = P1 then
return True;
-- No need to look any further since we have located a source
-- statement.
elsif Comes_From_Source (P2) then
exit;
end if;
-- Keep going left
Prev (P2);
end loop;
end if;
-- At this point either both nodes came from source or we approximated
-- their source locations through neighbouring source statements.
if Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)) then
return True;
else else
return Comes_From_Source (P1); return False;
end if; end if;
end Earlier; end Earlier;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment