Skip to content

R
riscv-gcc-1
Commit 6eca51ce by Ed Schonberg Committed by Arnaud Charlet
Options

exp_ch5.adb (Get_Default_Iterator): For a derived type... 

2017-01-06  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb (Get_Default_Iterator): For a derived type, the
	alias of the inherited op is the parent iterator, no need to
	examine dispatch table positions which might not be established
	yet if type is not frozen.
	* sem_disp.adb (Check_Controlling_Formals): The formal of a
	predicate function may be a subtype of a tagged type.
	* sem_ch3.adb (Complete_Private_Subtype): Adjust inheritance
	of representation items for the completion of a type extension
	where a predicate applies to the partial view.
	* checks.ads, checks.adb (Apply_Predicate_Check): Add optional
	parameter that designates function whose actual receives a
	predicate check, to improve warning message when the check will
	lead to infinite recursion.
	* sem_res.adb (Resolve_Actuals): Pass additional parameter to
	Apply_Predicate_Check.

From-SVN: r244132
parent 6413509b
Showing with 74 additions and 17 deletions
gcc/ada/ChangeLog
2017-01-06 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Get_Default_Iterator): For a derived type, the
alias of the inherited op is the parent iterator, no need to
examine dispatch table positions which might not be established
yet if type is not frozen.
* sem_disp.adb (Check_Controlling_Formals): The formal of a
predicate function may be a subtype of a tagged type.
* sem_ch3.adb (Complete_Private_Subtype): Adjust inheritance
of representation items for the completion of a type extension
where a predicate applies to the partial view.
* checks.ads, checks.adb (Apply_Predicate_Check): Add optional
parameter that designates function whose actual receives a
predicate check, to improve warning message when the check will
lead to infinite recursion.
* sem_res.adb (Resolve_Actuals): Pass additional parameter to
Apply_Predicate_Check.
2017-01-06 Tristan Gingold <gingold@adacore.com>
* s-rident.ads (Profile_Info): Remove No_Entry_Queue from
......
gcc/ada/checks.adb
......@@ -2605,7 +2605,11 @@ package body Checks is
-- Apply_Predicate_Check --
---------------------------
procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
procedure Apply_Predicate_Check
(N : Node_Id;
Typ : Entity_Id;
Fun : Entity_Id := Empty)
is
S : Entity_Id;
begin
......@@ -2633,11 +2637,18 @@ package body Checks is
-- is likely to be a common error, and thus deserves a warning.
elsif Present (S) and then S = Predicate_Function (Typ) then
Error_Msg_N
("predicate check includes a function call that "
& "requires a predicate check??", Parent (N));
Error_Msg_NE
("predicate check includes a call to& that "
& "requires a predicate check??", Parent (N), Fun);
Error_Msg_N
("\this will result in infinite recursion??", Parent (N));
if Is_First_Subtype (Typ) then
Error_Msg_NE
("\use an explicit subtype of& to carry the predicate",
Parent (N), Typ);
end if;
Insert_Action (N,
Make_Raise_Storage_Error (Sloc (N),
Reason => SE_Infinite_Recursion));
......
gcc/ada/checks.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
......@@ -255,9 +255,14 @@ package Checks is
-- verify the proper initialization of scalars in parameters and function
-- results.
procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id);
-- N is an expression to which a predicate check may need to be applied
-- for Typ, if Typ has a predicate function.
procedure Apply_Predicate_Check
(N : Node_Id;
Typ : Entity_Id;
Fun : Entity_Id := Empty);
-- N is an expression to which a predicate check may need to be applied for
-- Typ, if Typ has a predicate function. When N is an actual in a call, Fun
-- is the function being called, which is used to generate a better warning
-- if the call leads to an infinite recursion.
procedure Apply_Type_Conversion_Checks (N : Node_Id);
-- N is an N_Type_Conversion node. A type conversion actually involves
......
gcc/ada/exp_ch5.adb
......@@ -3769,14 +3769,17 @@ package body Exp_Ch5 is
elsif Is_Derived_Type (T) then
-- The default iterator must be a primitive operation of the
-- type, at the same dispatch slot position.
-- type, at the same dispatch slot position. The DT position
-- may not be established if type is not frozen yet.
Prim := First_Elmt (Primitive_Operations (T));
while Present (Prim) loop
Op := Node (Prim);
if Chars (Op) = Chars (Iter)
and then DT_Position (Op) = DT_Position (Iter)
if Alias (Op) = Iter
or else (Chars (Op) = Chars (Iter)
and then Present (DTC_Entity (Op))
and then DT_Position (Op) = DT_Position (Iter))
then
return Op;
end if;
......
gcc/ada/sem_ch3.adb
......@@ -11947,9 +11947,11 @@ package body Sem_Ch3 is
Append : Boolean;
Item : Node_Id;
Next_Item : Node_Id;
Priv_Item : Node_Id;
begin
Item := First_Rep_Item (Full);
Priv_Item := First_Rep_Item (Priv);
-- If no existing rep items on full type, we can just link directly
-- to the list of items on the private type, if any exist.. Same if
......@@ -11960,14 +11962,24 @@ package body Sem_Ch3 is
or else Entity (Item) = Full_Base)
and then Present (First_Rep_Item (Priv))
then
Set_First_Rep_Item (Full, First_Rep_Item (Priv));
Set_First_Rep_Item (Full, Priv_Item);
-- Otherwise, search to the end of items currently linked to the full
-- subtype and append the private items to the end. However, if Priv
-- and Full already have the same list of rep items, then the append
-- is not done, as that would create a circularity.
--
-- The partial view may have a predicate and the rep item lists of
-- both views agree when inherited from the same ancestor. In that
-- case, simply propagate the list from one view to the other.
-- A more complex analysis needed here ???
elsif Present (Priv_Item)
and then Item = Next_Rep_Item (Priv_Item)
then
Set_First_Rep_Item (Full, Priv_Item);
elsif Item /= First_Rep_Item (Priv) then
elsif Item /= Priv_Item then
Append := True;
loop
Next_Item := Next_Rep_Item (Item);
......
gcc/ada/sem_disp.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
......@@ -234,7 +234,13 @@ package body Sem_Disp is
Formal);
end if;
elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
-- Within a predicate function, the formal may be a subtype
-- of a tagged type, given that the predicate is expressed
-- in terms of the subtype.
elsif not Subtypes_Statically_Match (Typ, Etype (Formal))
and then not Is_Predicate_Function (Subp)
then
Error_Msg_N
("parameter subtype does not match controlling type",
Formal);
......
gcc/ada/sem_res.adb
......@@ -4265,10 +4265,12 @@ package body Sem_Res is
-- Apply predicate tests except in certain special cases. Note
-- that it might be more consistent to apply these only when
-- expansion is active (in Exp_Ch6.Expand_Actuals), as we do
-- for the outbound predicate tests ???
-- for the outbound predicate tests ??? In any case indicate
-- the function being called, for better warnings if the call
-- leads to an infinite recursion.
if Predicate_Tests_On_Arguments (Nam) then
Apply_Predicate_Check (A, F_Typ);
Apply_Predicate_Check (A, F_Typ, Nam);
end if;
-- Apply required constraint checks
......
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