From patchwork Fri Oct 22 08:52:17 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68812 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 DA2E4B70DC for ; Fri, 22 Oct 2010 19:52:32 +1100 (EST) Received: (qmail 15780 invoked by alias); 22 Oct 2010 08:52:29 -0000 Received: (qmail 15761 invoked by uid 22791); 22 Oct 2010 08:52:25 -0000 X-SWARE-Spam-Status: No, hits=-1.5 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 08:52:19 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 78242CB024C; Fri, 22 Oct 2010 10:52:17 +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 e-ae4Saj6eeI; Fri, 22 Oct 2010 10:52:17 +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 5CD56CB01EC; Fri, 22 Oct 2010 10:52:17 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 40335D9BB4; Fri, 22 Oct 2010 10:52:17 +0200 (CEST) Date: Fri, 22 Oct 2010 10:52:17 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Work on inherited predicates (interim step) Message-ID: <20101022085217.GA9907@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 includes some fixes for handling of inherited predicates but this is not quite working fully yet, so a test is not needed yet. Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-22 Robert Dewar * einfo.ads, einfo.adb (Has_Predicates): Flag is now on all entities (simplifies code). * exp_ch13.adb (Build_Predicate_Function): Output info msgs for inheritance. * sem_ch13.adb (Analyze_Aspect_Specifications): Make sure we have a freeze node for entities for which a predicate is specified. (Analyze_Aspect_Specifications): Avoid duplicate calls * sem_ch3.adb (Analyze_Full_Type_Declaration): Remove attempt to avoid duplicate calls to Analye_Aspect_Specifications. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165803) +++ sem_ch3.adb (working copy) @@ -2403,9 +2403,7 @@ package body Sem_Ch3 is Set_Optimize_Alignment_Flags (Def_Id); Check_Eliminated (Def_Id); - if Nkind (N) = N_Full_Type_Declaration then - Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); - end if; + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); end Analyze_Full_Type_Declaration; ---------------------------------- @@ -4215,8 +4213,8 @@ package body Sem_Ch3 is Set_Optimize_Alignment_Flags (Id); Check_Eliminated (Id); - <> - Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + <> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Subtype_Declaration; -------------------------------- Index: einfo.adb =================================================================== --- einfo.adb (revision 165803) +++ einfo.adb (working copy) @@ -1411,7 +1411,6 @@ package body Einfo is function Has_Predicates (Id : E) return B is begin - pragma Assert (Is_Type (Id) or else Is_Subprogram (Id)); return Flag250 (Id); end Has_Predicates; @@ -3863,9 +3862,6 @@ package body Einfo is procedure Set_Has_Predicates (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Function - or else Ekind (Id) = E_Void); Set_Flag250 (Id, V); end Set_Has_Predicates; Index: einfo.ads =================================================================== --- einfo.ads (revision 165803) +++ einfo.ads (working copy) @@ -1674,11 +1674,11 @@ package Einfo is -- such an object and no warning is generated. -- Has_Predicates (Flag250) --- Present in type and subtype entities and in subprogram entities. Set --- if a pragma Predicate or Predicate aspect applies to the type, or if --- it inherits a Predicate aspect from its parent or progenitor types. --- Also set in the predicate function entity, to distinguish it among --- entries in the Subprograms_For_Type. +-- Present in all entities. Set in type and subtype entities if a pragma +-- Predicate or Predicate aspect applies to the type, or if it inherits a +-- Predicate aspect from its parent or progenitor types. Also set in the +-- predicate function entity, to distinguish it among entries in the +-- Subprograms_For_Type. -- Has_Primitive_Operations (Flag120) [base type only] -- Present in all type entities. Set if at least one primitive operation @@ -4666,6 +4666,7 @@ package Einfo is -- Has_Pragma_Thread_Local_Storage (Flag169) -- Has_Pragma_Unmodified (Flag233) -- Has_Pragma_Unreferenced (Flag180) + -- Has_Predicates (Flag250) -- Has_Private_Declaration (Flag155) -- Has_Qualified_Name (Flag161) -- Has_Stream_Size_Clause (Flag184) @@ -4778,7 +4779,6 @@ package Einfo is -- Has_Object_Size_Clause (Flag172) -- Has_Pragma_Preelab_Init (Flag221) -- Has_Pragma_Unreferenced_Objects (Flag212) - -- Has_Predicates (Flag250) -- Has_Primitive_Operations (Flag120) (base type only) -- Has_Size_Clause (Flag29) -- Has_Specified_Layout (Flag100) (base type only) @@ -5138,7 +5138,6 @@ package Einfo is -- Has_Missing_Return (Flag142) -- Has_Nested_Block_With_Handler (Flag101) -- Has_Postconditions (Flag240) - -- Has_Predicates (Flag250) -- Has_Recursive_Call (Flag143) -- Has_Subprogram_Descriptor (Flag93) -- Is_Abstract_Subprogram (Flag19) (non-generic case only) @@ -5271,7 +5270,6 @@ package Einfo is -- Subprograms_For_Type (Node29) -- Has_Invariants (Flag232) -- Has_Postconditions (Flag240) - -- Has_Predicates (Flag250) -- Is_Machine_Code_Subprogram (Flag137) -- Is_Pure (Flag44) -- Is_Intrinsic_Subprogram (Flag64) @@ -5403,7 +5401,6 @@ package Einfo is -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) -- Has_Postconditions (Flag240) - -- Has_Predicates (Flag250) -- Has_Subprogram_Descriptor (Flag93) -- Is_Abstract_Subprogram (Flag19) (non-generic case only) -- Is_Asynchronous (Flag81) Index: exp_ch13.adb =================================================================== --- exp_ch13.adb (revision 165803) +++ exp_ch13.adb (working copy) @@ -27,6 +27,7 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; +with Errout; use Errout; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Imgv; use Exp_Imgv; @@ -126,12 +127,17 @@ package body Exp_Ch13 is begin if Present (T) and then Present (Predicate_Function (T)) then + + -- Build the call to the predicate function of T + Exp := Make_Predicate_Call (T, Convert_To (T, Make_Identifier (Loc, Chars => Object_Name))); + -- Add call to evolving expression, using AND THEN if needed + if No (Expr) then Expr := Exp; else @@ -140,6 +146,14 @@ package body Exp_Ch13 is Left_Opnd => Relocate_Node (Expr), Right_Opnd => Exp); end if; + + -- Output info message on inheritance if required + + 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); + end if; end if; end Add_Call; @@ -200,24 +214,27 @@ package body Exp_Ch13 is Arg1 := Get_Pragma_Arg (Arg1); Arg2 := Get_Pragma_Arg (Arg2); - -- We need to replace any occurrences of the name of the type - -- with references to the object. We do this by first doing a - -- preanalysis, to identify all the entities, then we traverse - -- looking for the type entity, doing the needed substitution. - -- The preanalysis is done with the special OK_To_Reference - -- flag set on the type, so that if we get an occurrence of - -- this type, it will be recognized as legitimate. - - Set_OK_To_Reference (Typ, True); - Preanalyze_Spec_Expression (Arg2, Standard_Boolean); - Set_OK_To_Reference (Typ, False); - Replace_Type (Arg2); - -- See if this predicate pragma is for the current type if Entity (Arg1) = Typ then - -- We have a match, add the expression + -- We have a match, this entry is for our subtype + + -- First We need to replace any occurrences of the name of + -- the type with references to the object. We do this by + -- first doing a preanalysis, to identify all the entities, + -- then we traverse looking for the type entity, doing the + -- needed substitution. The preanalysis is done with the + -- special OK_To_Reference flag set on the type, so that if + -- we get an occurrence of this type, it will be recognized + -- as legitimate. + + Set_OK_To_Reference (Typ, True); + Preanalyze_Spec_Expression (Arg2, Standard_Boolean); + Set_OK_To_Reference (Typ, False); + Replace_Type (Arg2); + + -- OK, replacement complete, now we can add the expression if No (Expr) then Expr := Relocate_Node (Arg2); Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 165803) +++ sem_ch13.adb (working copy) @@ -658,10 +658,21 @@ package body Sem_Ch13 is -- Set True if delay is required begin + -- Return if no aspects + if L = No_List then return; end if; + -- Return if already analyzed (avoids duplicate calls in some cases + -- where type declarations get rewritten and proessed twice). + + if Analyzed (N) then + return; + end if; + + -- Loop through apsects + Aspect := First (L); while Present (Aspect) loop declare @@ -1068,6 +1079,12 @@ package body Sem_Ch13 is Set_From_Aspect_Specification (Aitem, True); + -- Make sure we have a freeze node (it might otherwise be + -- missing in cases like subtype X is Y, and we would not + -- have a place to build the predicate function). + + Ensure_Freeze_Node (E); + -- For Predicate case, insert immediately after the entity -- declaration. We do not have to worry about delay issues -- since the pragma processing takes care of this.