mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-19 22:31:07 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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
This commit is contained in:
Arnaud Charlet 2012-01-23 10:39:27 +01:00
parent 3c24c853da
commit 88a27b18dd
6 changed files with 318 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
gcc/ada/ChangeLog
View File

@ -1,3 +1,30 @@
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>
* a-cohase.ads, a-cihase.ads, a-cbhase.ads, a-coorse.ads,

39
gcc/ada/exp_ch4.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -2601,6 +2601,12 @@ package body Exp_Ch4 is
-- This is either an integer literal node, or an identifier reference to
-- 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;
-- 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
@ -2811,11 +2817,14 @@ package body Exp_Ch4 is
Result_May_Be_Null := False;
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
Last_Opnd_Low_Bound :=
New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
Last_Opnd_High_Bound :=
Make_Op_Add (Loc,
Make_Op_Subtract (Loc,
Left_Opnd =>
New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
Right_Opnd => Make_Integer_Literal (Loc, 1));
@ -2871,9 +2880,13 @@ package body Exp_Ch4 is
Result_May_Be_Null := False;
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
Last_Opnd_Low_Bound :=
Convert_To (Ityp,
Make_Integer_Literal (Loc, Expr_Value (Lo)));
Last_Opnd_High_Bound :=
Convert_To (Ityp,
Make_Integer_Literal (Loc, Expr_Value (Hi)));
@ -2914,7 +2927,16 @@ package body Exp_Ch4 is
Duplicate_Subexpr (Opnd, Name_Req => True),
Attribute_Name => Name_First);
-- Capture last operand bounds if result could be null
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 :=
Convert_To (Ityp,
Make_Attribute_Reference (Loc,
@ -3124,6 +3146,15 @@ package body Exp_Ch4 is
-- bounds if the last operand is super-flat).
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 :=
Make_Conditional_Expression (Loc,
Expressions => New_List (

4
gcc/ada/get_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- --
@ -301,7 +301,7 @@ begin
when others =>
Skipc;
if Typ = 'P' then
if Typ = 'P' or else Typ = 'p' then
if Nextc not in '1' .. '9' then
N := 1;
loop

11
gcc/ada/put_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- --
@ -139,12 +139,6 @@ begin
Ctr := 0;
Continuation := False;
loop
if SCO_Pragma_Disabled
(SCO_Table.Table (Start).Pragma_Sloc)
then
goto Next_Statement;
end if;
if Ctr = 0 then
Write_SCO_Initiate (U);
if not Continuation then
@ -169,7 +163,7 @@ begin
Write_Info_Char (Sent.C2);
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
then
-- Strip leading "PRAGMA_"
@ -205,7 +199,6 @@ begin
Ctr := 0;
end if;
<<Next_Statement>>
exit when SCO_Table.Table (Start).Last;
Start := Start + 1;
end loop;

3
gcc/ada/scos.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -157,6 +157,7 @@ package SCOs is
-- F FOR loop (from FOR through end of iteration scheme)
-- I IF statement (from IF through end of condition)
-- P[name:] PRAGMA with the indicated name
-- p[name:] disabled PRAGMA with the indicated name
-- R extended RETURN statement
-- W WHILE loop statement (from WHILE through end of condition)

299
gcc/ada/sem_ch12.adb
View File

@ -917,20 +917,20 @@ package body Sem_Ch12 is
Formals : List_Id;
F_Copy : List_Id) return List_Id
is
Actual_Types : constant Elist_Id := New_Elmt_List;
Assoc : constant List_Id := New_List;
Default_Actuals : constant Elist_Id := New_Elmt_List;
Gen_Unit : constant Entity_Id :=
Defining_Entity (Parent (F_Copy));
Actuals_To_Freeze : constant Elist_Id := New_Elmt_List;
Assoc : constant List_Id := New_List;
Default_Actuals : constant Elist_Id := New_Elmt_List;
Gen_Unit : constant Entity_Id :=
Defining_Entity (Parent (F_Copy));
Actuals : List_Id;
Actual : Node_Id;
Formal : Node_Id;
Next_Formal : Node_Id;
Analyzed_Formal : Node_Id;
First_Named : Node_Id := Empty;
Formal : Node_Id;
Match : Node_Id;
Named : Node_Id;
First_Named : Node_Id := Empty;
Saved_Formal : Node_Id;
Default_Formals : constant List_Id := New_List;
-- If an Others_Choice is present, some of the formals may be defaulted.
@ -958,6 +958,10 @@ package body Sem_Ch12 is
-- to formals of formal packages by AI05-0025, and it also applies to
-- 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
(F : Entity_Id;
A_F : Entity_Id) return Node_Id;
@ -966,7 +970,7 @@ package body Sem_Ch12 is
-- are named, scan the parameter associations to find the right one.
-- A_F is the corresponding entity in the analyzed generic,which is
-- placed on the selector name for ASIS use.
--
-- In Ada 2005, a named association may be given with a box, in which
-- case Matching_Actual sets Found_Assoc to the generic association,
-- but return Empty for the actual itself. In this case the code below
@ -982,6 +986,10 @@ package body Sem_Ch12 is
-- associations, and add an explicit box association for F if there
-- 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;
-- Find the node in the generic copy that corresponds to a given formal.
-- The semantic information on this node is used to perform legality
@ -1025,6 +1033,62 @@ package body Sem_Ch12 is
end loop;
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 --
---------------------
@ -1149,6 +1213,26 @@ package body Sem_Ch12 is
end if;
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 --
-------------------------
@ -1259,7 +1343,7 @@ package body Sem_Ch12 is
Named := First_Named;
while Present (Named) loop
if Nkind (Named) /= N_Others_Choice
and then No (Selector_Name (Named))
and then No (Selector_Name (Named))
then
Error_Msg_N ("invalid positional actual after named one", Named);
Abandon_Instantiation (Named);
@ -1293,7 +1377,7 @@ package body Sem_Ch12 is
while Present (Formal) loop
Set_Analyzed_Formal;
Next_Formal := Next_Non_Pragma (Formal);
Saved_Formal := Next_Non_Pragma (Formal);
case Nkind (Formal) is
when N_Formal_Object_Declaration =>
@ -1335,19 +1419,24 @@ package body Sem_Ch12 is
Analyze (Match);
Append_List
(Instantiate_Type
(Formal, Match, Analyzed_Formal, Assoc),
Assoc);
(Formal, Match, Analyzed_Formal, Assoc),
Assoc);
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package, or the
-- formal is an Ada 2012 formal incomplete type.
if Nkind (I_Node) /= N_Formal_Package_Declaration
and then
Ekind (Defining_Identifier (Analyzed_Formal)) /=
E_Incomplete_Type
if Nkind (I_Node) = N_Formal_Package_Declaration
or else
(Ada_Version >= Ada_2012
and then
Ekind (Defining_Identifier (Analyzed_Formal)) =
E_Incomplete_Type)
then
Append_Elmt (Entity (Match), Actual_Types);
null;
else
Append_Elmt (Entity (Match), Actuals_To_Freeze);
end if;
end if;
@ -1364,9 +1453,9 @@ package body Sem_Ch12 is
when N_Formal_Subprogram_Declaration =>
Match :=
Matching_Actual (
Defining_Unit_Name (Specification (Formal)),
Defining_Unit_Name (Specification (Analyzed_Formal)));
Matching_Actual
(Defining_Unit_Name (Specification (Formal)),
Defining_Unit_Name (Specification (Analyzed_Formal)));
-- If the formal subprogram has the same name as another
-- formal subprogram of the generic, then a named
@ -1384,10 +1473,9 @@ package body Sem_Ch12 is
-- partial parametrization, or else the formal has a default
-- or a box.
if No (Match)
and then Partial_Parametrization
then
if No (Match) and then Partial_Parametrization then
Process_Default (Formal);
if Nkind (I_Node) = N_Formal_Package_Declaration then
Check_Overloaded_Formal_Subprogram (Formal);
end if;
@ -1396,6 +1484,37 @@ package body Sem_Ch12 is
Append_To (Assoc,
Instantiate_Formal_Subprogram
(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;
-- If this is a nested generic, preserve default for later
@ -1459,7 +1578,7 @@ package body Sem_Ch12 is
end case;
Formal := Next_Formal;
Formal := Saved_Formal;
Next_Non_Pragma (Analyzed_Formal);
end loop;
@ -1484,8 +1603,12 @@ package body Sem_Ch12 is
("too many actuals in generic instantiation", Instantiation_Node);
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
Elmt : Elmt_Id := First_Elmt (Actual_Types);
Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze);
begin
while Present (Elmt) loop
Freeze_Before (I_Node, Node (Elmt));
@ -6818,11 +6941,6 @@ package body Sem_Ch12 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);
-- Find distance from given node to enclosing compilation unit
@ -6840,6 +6958,13 @@ package body Sem_Ch12 is
end loop;
end Find_Depth;
-- Local declarations
D1 : Integer := 0;
D2 : Integer := 0;
P1 : Node_Id := N1;
P2 : Node_Id := N2;
-- Start of processing for Earlier
begin
@ -6864,12 +6989,11 @@ package body Sem_Ch12 is
end loop;
-- 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,
-- at which point we can establish their relative placement by
-- comparing their ultimate slocs. If we reach the root, N1 and N2
-- do not descend from the same declarative list (e.g. one is nested
-- in the declarative part and the other is in a block in the
-- statement part) and the earlier one is already frozen.
-- We examine their parents until we find a common declarative list.
-- If we reach the root, N1 and N2 do not descend from the same
-- declarative list (e.g. one is nested in the declarative part and
-- the other is in a block in the statement part) and the earlier
-- one is already frozen.
while not Is_List_Member (P1)
or else not Is_List_Member (P2)
@ -6891,22 +7015,99 @@ package body Sem_Ch12 is
end if;
end loop;
-- If the sloc positions are different the result is unambiguous. If
-- the slocs are identical, one of them must not come from source, which
-- is the case for freeze nodes, whose sloc is unrelated to the point
-- point at which they are inserted in the tree. The source node is the
-- earlier one in the tree.
-- Expanded code usually shares the source location of the original
-- construct it was generated for. This however may not necessarely
-- reflect the true location of the code within the tree.
-- Before comparing the slocs of the two nodes, make sure that we are
-- 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.
-- P1 P2
-- ----+===+===+--------------+===+===+----
-- expanded code expanded code
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;
elsif
Top_Level_Location (Sloc (P1)) > Top_Level_Location (Sloc (P2))
then
return False;
else
return Comes_From_Source (P1);
return False;
end if;
end Earlier;