===================================================================
@@ -749,6 +749,46 @@ package body Sem_Aux is
end if;
end Is_Limited_Type;
+ ----------------------
+ -- Nearest_Ancestor --
+ ----------------------
+
+ function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
+ D : constant Node_Id := Declaration_Node (Typ);
+
+ begin
+ -- If we have a subtype declaration, get the ancestor subtype
+
+ if Nkind (D) = N_Subtype_Declaration then
+ if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
+ return Entity (Subtype_Mark (Subtype_Indication (D)));
+ else
+ return Entity (Subtype_Indication (D));
+ end if;
+
+ -- If derived type declaration, find who we are derived from
+
+ elsif Nkind (D) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
+ then
+ declare
+ DTD : constant Entity_Id := Type_Definition (D);
+ SI : constant Entity_Id := Subtype_Indication (DTD);
+ begin
+ if Is_Entity_Name (SI) then
+ return Entity (SI);
+ else
+ return Entity (Subtype_Mark (SI));
+ end if;
+ end;
+
+ -- Otherwise, nothing useful to return, return Empty
+
+ else
+ return Empty;
+ end if;
+ end Nearest_Ancestor;
+
---------------------------
-- Nearest_Dynamic_Scope --
---------------------------
===================================================================
@@ -181,6 +181,24 @@ package Sem_Aux is
-- composite containing a limited component, or a subtype of any of
-- these types).
+ function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
+ -- Given a subtype Typ, this function finds out the nearest ancestor from
+ -- which constraints and predicates are inherited. There is no simple link
+ -- for doing this, consider:
+ --
+ -- subtype R is Integer range 1 .. 10;
+ -- type T is new R;
+ --
+ -- In this case the nearest ancestor is R, but the Etype of T'Base will
+ -- point to R'Base, so we have to go rummaging in the declarations to get
+ -- this information. It is used for making sure we freeze this before we
+ -- freeze Typ, and also for retrieving inherited predicate information.
+ -- For the case of base types or first subtypes, there is no useful entity
+ -- to return, so Empty is returned.
+ --
+ -- Note: this is similar to Ancestor_Subtype except that it also deals
+ -- with the case of derived types.
+
function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
-- This is similar to Enclosing_Dynamic_Scope except that if Ent is itself
-- a dynamic scope, then it is returned. Otherwise the result is the same
===================================================================
@@ -1759,9 +1759,7 @@ package body Checks is
procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
begin
- if Etype (N) /= Typ
- and then Present (Predicate_Function (Typ))
- then
+ if Present (Predicate_Function (Typ)) then
Insert_Action (N,
Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
end if;
===================================================================
@@ -3096,18 +3096,31 @@ package body Freeze is
end if;
-- If ancestor subtype present, freeze that first. Note that this
- -- will also get the base type frozen.
+ -- will also get the base type frozen. Need RM reference ???
Atype := Ancestor_Subtype (E);
if Present (Atype) then
Freeze_And_Append (Atype, N, Result);
- -- Otherwise freeze the base type of the entity before freezing
- -- the entity itself (RM 13.14(15)).
+ -- No ancestor subtype present
- elsif E /= Base_Type (E) then
- Freeze_And_Append (Base_Type (E), N, Result);
+ else
+ -- See if we have a nearest ancestor that has a predicate.
+ -- That catches the case of derived type with a predicate.
+ -- Need RM reference here ???
+
+ Atype := Nearest_Ancestor (E);
+
+ if Present (Atype) and then Has_Predicates (Atype) then
+ Freeze_And_Append (Atype, N, Result);
+ end if;
+
+ -- Freeze base type before freezing the entity (RM 13.14(15))
+
+ if E /= Base_Type (E) then
+ Freeze_And_Append (Base_Type (E), N, Result);
+ end if;
end if;
-- For a derived type, freeze its parent type first (RM 13.14(15))
===================================================================
@@ -152,7 +152,7 @@ package body Exp_Ch13 is
if Opt.List_Inherited_Aspects then
Error_Msg_Sloc := Sloc (Predicate_Function (T));
Error_Msg_Node_2 := T;
- Error_Msg_N ("?info: & inherits predicate from & at #", Typ);
+ Error_Msg_N ("?info: & inherits predicate from & #", Typ);
end if;
end if;
end Add_Call;
@@ -272,21 +272,13 @@ package body Exp_Ch13 is
Add_Predicates;
- -- Deal with ancestor subtype and parent type
+ -- Add predicates for ancestor if present
declare
- Atyp : constant Entity_Id := Ancestor_Subtype (Typ);
-
+ Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
begin
- -- If ancestor subtype present, add its predicates
-
if Present (Atyp) then
Add_Call (Atyp);
-
- -- Else if this is derived, add predicates of parent type
-
- elsif Is_Derived_Type (Typ) then
- Add_Call (Etype (Base_Type (Typ)));
end if;
end;
This patch finalizes the proper treatment of inheritance for predicates. The following test compiles as shown with -gnata12 -gnatld7 -gnatj60 and generates no output when run: 1. with Ada.Assertions; use Ada.Assertions; 2. procedure inherit_predicates is 3. type r is new integer range 1 .. 100 with 4. predicate => r mod 2 = 1; 5. 6. subtype s is r with | >>> info: "s" inherits predicate from "r" at line 3 7. predicate => s <= 13; 8. 9. type q is new s with | >>> info: "q" inherits predicate from "s" at line 6 10. predicate => q mod 3 = 0; 11. 12. qv : q; 13. 14. begin 15. begin 16. qv := 11; -- not divisible by 3 17. raise Program_Error; 18. exception 19. when Assertion_Error => 20. null; 21. end; 22. 23. begin 24. qv := 21; -- greater than 13 25. raise Program_Error; 26. exception 27. when Assertion_Error => 28. null; 29. end; 30. 31. begin 32. qv := 6; -- not odd 33. raise Program_Error; 34. exception 35. when Assertion_Error => 36. null; 37. end; 38. 39. begin 40. qv := 9; -- ok 41. end; 42. end inherit_predicates; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-22 Robert Dewar <dewar@adacore.com> * checks.adb (Apply_Predicate_Check): Remove attempt at optimization when subtype is the same, caused legitimate checks to be missed. * exp_ch13.adb (Build_Predicate_Function): Use Nearest_Ancestor to get inheritance from right entity. * freeze.adb (Freeze_Entity): Use Nearest_Ancestor to freeze in the derived type case if the ancestor type has predicates. * sem_aux.ads, sem_aux.adb (Nearest_Ancestor): New function.