+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
-- 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
-- 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));
-- --
-- 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- --
-- 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
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;
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
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);
-- --
-- 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- --
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);
-- 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
projects / gcc.git / commitdiff