From patchwork Fri Oct 22 09:20:11 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68816 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 0624E1007D3 for ; Fri, 22 Oct 2010 20:20:28 +1100 (EST) Received: (qmail 29782 invoked by alias); 22 Oct 2010 09:20:25 -0000 Received: (qmail 29765 invoked by uid 22791); 22 Oct 2010 09:20:23 -0000 X-SWARE-Spam-Status: No, hits=-1.6 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 22 Oct 2010 09:20:14 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 20E15CB0223; Fri, 22 Oct 2010 11:20:12 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id bwg9cL3w5IRy; Fri, 22 Oct 2010 11:20:12 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 0A9E1CB01EF; Fri, 22 Oct 2010 11:20:12 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id D8D54D9BB4; Fri, 22 Oct 2010 11:20:11 +0200 (CEST) Date: Fri, 22 Oct 2010 11:20:11 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Implement inheritance for predicates Message-ID: <20101022092011.GA12472@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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. Index: sem_aux.adb =================================================================== --- sem_aux.adb (revision 165803) +++ sem_aux.adb (working copy) @@ -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 -- --------------------------- Index: sem_aux.ads =================================================================== --- sem_aux.ads (revision 165803) +++ sem_aux.ads (working copy) @@ -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 Index: checks.adb =================================================================== --- checks.adb (revision 165803) +++ checks.adb (working copy) @@ -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; Index: freeze.adb =================================================================== --- freeze.adb (revision 165804) +++ freeze.adb (working copy) @@ -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)) Index: exp_ch13.adb =================================================================== --- exp_ch13.adb (revision 165804) +++ exp_ch13.adb (working copy) @@ -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;