From patchwork Fri Oct 5 14:32:20 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 189499 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 C4FA72C0321 for ; Sat, 6 Oct 2012 00:32:40 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1350052361; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=xCcm6rklwRj1ootzDJZu z/ZWKaU=; b=BEKMBdkLdq2PXPeS4e2feREB3jHyvVvj1EMrsKwAdoZs9dqhSgLj xrxil1GgIOl+9Z4J5S7mWExGqsbR+9h7UXXdc91iacgjCn0TrfcxoX8SUK6LqAuW ZhvnohuUH2ZZJG54gQIv0jre0tGEVx4sUPxWpKDgwvIFyZPupMIAO5U= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=nOrBNPSQHWYN8e7kab2LYtGLiPwK0cC8hXUNAu2N3dp9MNwqyk9N4Q2obJxf/Y 1DCaSSTbXCARZRNYBIqPlcH2oDMBKNdR+WVlEXiq6P2qXnJ+a5dT49kwjJSmiLs7 uKDQI9pxD7vEqI+eER5I7zfwnBDvt/MFBchl6djwR1e0E=; Received: (qmail 9476 invoked by alias); 5 Oct 2012 14:32:30 -0000 Received: (qmail 9424 invoked by uid 22791); 5 Oct 2012 14:32:29 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO, TW_TM X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 05 Oct 2012 14:32:21 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A83401C77E5; Fri, 5 Oct 2012 10:32:20 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id UOoGIUEguvYx; Fri, 5 Oct 2012 10:32:20 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 7A4211C7686; Fri, 5 Oct 2012 10:32:20 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 788A1919E3; Fri, 5 Oct 2012 10:32:20 -0400 (EDT) Date: Fri, 5 Oct 2012 10:32:20 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Handling of Invariant aspect on type completions Message-ID: <20121005143220.GA11558@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 fixes the handling of type invariants when they are specified on the completion of a private type, and when public expression functions return a type with invariants. Running the following: gnatmake -q -gnat12a main main must yield: OK --- with Ada.Assertions; use Ada.Assertions; with Text_IO; use Text_IO; with R; use R; procedure Main is X : T; begin X := Zero; Put_Line ("Invariant violated"); exception when Assertion_Error => Put_Line ("OK"); end Main; --- package R is type T is private;; function Non_Null (X : T) return Boolean; function Zero return T; private type T is new Integer with Type_Invariant => T /= 0; function Non_Null (X : T) return Boolean is (X /= 0); function Zero return T is (0); end R; Tested on x86_64-pc-linux-gnu, committed on trunk 2012-10-05 Ed Schonberg * einfo.adb (Set_Invariant_Procedure, Set_Predicate_Function): chain properly subprograms on Subprograms_For_Type list. * sem_ch13.ads; (Build_Invariant_Procedure_Declaration): new procedure, to create declaration for invariant procedure independently of the construction of the body, so that it can be called within expression functions. * sem_ch13.adb (Build_Invariant_Procedure): code cleanup. The declaration may already have been generated at the point an explicit invariant aspect is encountered. * sem_prag.adb; (Analyze_Pragma, case Invariant): create declaration for invariant procedure. * sem_ch7.adb (Analyze_Package_Specification): clean up call to build invariant procedure. (Preserve_Full_Attributes): propagate information about invariants if they appear on a completion, Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 192066) +++ sem_ch7.adb (working copy) @@ -28,6 +28,7 @@ -- handling of private and full declarations, and the construction of dispatch -- tables for tagged types. +with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; @@ -1387,7 +1388,21 @@ and then Nkind (Parent (E)) = N_Full_Type_Declaration and then Has_Aspects (Parent (E)) then - Build_Invariant_Procedure (E, N); + declare + ASN : Node_Id; + begin + ASN := First (Aspect_Specifications (Parent (E))); + while Present (ASN) loop + if Chars (Identifier (ASN)) = Name_Invariant + or else Chars (Identifier (ASN)) = Name_Type_Invariant + then + Build_Invariant_Procedure (E, N); + exit; + end if; + + Next (ASN); + end loop; + end; end if; Next_Entity (E); @@ -2143,6 +2158,14 @@ Set_Freeze_Node (Priv, Freeze_Node (Full)); + -- Propagate information of type invariants, which may be specified + -- for the full view. + + if Has_Invariants (Full) and not Has_Invariants (Priv) then + Set_Has_Invariants (Priv); + Set_Subprograms_For_Type (Priv, Subprograms_For_Type (Full)); + end if; + if Is_Tagged_Type (Priv) and then Is_Tagged_Type (Full) and then not Error_Posted (Full) Index: einfo.adb =================================================================== --- einfo.adb (revision 192066) +++ einfo.adb (working copy) @@ -7113,6 +7113,7 @@ S := Subprograms_For_Type (Id); Set_Subprograms_For_Type (Id, V); + Set_Subprograms_For_Type (V, S); while Present (S) loop if Has_Invariants (S) then @@ -7121,8 +7122,6 @@ S := Subprograms_For_Type (S); end if; end loop; - - Set_Subprograms_For_Type (Id, V); end Set_Invariant_Procedure; ---------------------------- @@ -7137,6 +7136,7 @@ S := Subprograms_For_Type (Id); Set_Subprograms_For_Type (Id, V); + Set_Subprograms_For_Type (V, S); while Present (S) loop if Has_Predicates (S) then @@ -7145,8 +7145,6 @@ S := Subprograms_For_Type (S); end if; end loop; - - Set_Subprograms_For_Type (Id, V); end Set_Predicate_Function; ----------------- Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 192124) +++ sem_prag.adb (working copy) @@ -10329,6 +10329,7 @@ when Pragma_Invariant => Invariant : declare Type_Id : Node_Id; Typ : Entity_Id; + PDecl : Node_Id; Discard : Boolean; pragma Unreferenced (Discard); @@ -10380,8 +10381,13 @@ -- Note that the type has at least one invariant, and also that -- it has inheritable invariants if we have Invariant'Class. + -- Build the corresponding invariant procedure declaration, so + -- that calls to it can be generated before the body is built + -- (for example wihin an expression function). - Set_Has_Invariants (Typ); + PDecl := Build_Invariant_Procedure_Declaration (Typ); + Insert_After (N, PDecl); + Analyze (PDecl); if Class_Present (N) then Set_Has_Inheritable_Invariants (Typ); Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 192066) +++ sem_ch13.adb (working copy) @@ -4902,6 +4902,48 @@ end if; end Analyze_Record_Representation_Clause; + ------------------------------------------- + -- Build_Invariant_Procedure_Declaration -- + ------------------------------------------- + + function Build_Invariant_Procedure_Declaration + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + Spec : Node_Id; + SId : Entity_Id; + + begin + Set_Etype (Object_Entity, Typ); + + -- Check for duplicate definiations. + + if Has_Invariants (Typ) + and then Present (Invariant_Procedure (Typ)) + then + return Empty; + end if; + + SId := Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Invariant")); + Set_Has_Invariants (SId); + Set_Has_Invariants (Typ); + Set_Ekind (SId, E_Procedure); + Set_Invariant_Procedure (Typ, SId); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + + return Make_Subprogram_Declaration (Loc, Specification => Spec); + end Build_Invariant_Procedure_Declaration; + ------------------------------- -- Build_Invariant_Procedure -- ------------------------------- @@ -4936,12 +4978,11 @@ -- "inherited" to the exception message and generating an informational -- message about the inheritance of an invariant. - Object_Name : constant Name_Id := New_Internal_Name ('I'); + Object_Name : Name_Id; -- Name for argument of invariant procedure - Object_Entity : constant Node_Id := - Make_Defining_Identifier (Loc, Object_Name); - -- The procedure declaration entity for the argument + Object_Entity : Node_Id; + -- The entity of the formal for the procedure -------------------- -- Add_Invariants -- @@ -5140,8 +5181,30 @@ Stmts := No_List; PDecl := Empty; PBody := Empty; - Set_Etype (Object_Entity, Typ); + SId := Empty; + -- If the aspect specification exists for some view of the type, the + -- declaration for the procedure has been created. + + if Has_Invariants (Typ) then + SId := Invariant_Procedure (Typ); + end if; + + if Present (SId) then + PDecl := Unit_Declaration_Node (SId); + + else + PDecl := Build_Invariant_Procedure_Declaration (Typ); + end if; + + -- Recover formal of procedure, for use in the calls to invariant + -- functions (including inherited ones). + + Object_Entity := + Defining_Identifier + (First (Parameter_Specifications (Specification (PDecl)))); + Object_Name := Chars (Object_Entity); + -- Add invariants for the current type Add_Invariants (Typ, Inherit => False); @@ -5174,39 +5237,8 @@ if Stmts /= No_List then - -- Build procedure declaration + Spec := Copy_Separate_Tree (Specification (PDecl)); - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Invariant")); - Set_Has_Invariants (SId); - Set_Invariant_Procedure (Typ, SId); - - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity, - Parameter_Type => New_Occurrence_Of (Typ, Loc)))); - - PDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); - - -- Build procedure body - - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Invariant")); - - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => New_Occurrence_Of (Typ, Loc)))); - PBody := Make_Subprogram_Body (Loc, Specification => Spec, @@ -5216,14 +5248,18 @@ Statements => Stmts)); -- Insert procedure declaration and spec at the appropriate points. + -- If declaration is already analyzed, it was processed by the + -- generated pragma. if Present (Private_Decls) then -- The spec goes at the end of visible declarations, but they have -- already been analyzed, so we need to explicitly do the analyze. - Append_To (Visible_Decls, PDecl); - Analyze (PDecl); + if not Analyzed (PDecl) then + Append_To (Visible_Decls, PDecl); + Analyze (PDecl); + end if; -- The body goes at the end of the private declarations, which we -- have not analyzed yet, so we do not need to perform an explicit @@ -5523,6 +5559,7 @@ Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Typ), "Predicate")); Set_Has_Predicates (SId); + Set_Ekind (SId, E_Function); Set_Predicate_Function (Typ, SId); -- The predicate function is shared between views of a type. Index: sem_ch13.ads =================================================================== --- sem_ch13.ads (revision 192066) +++ sem_ch13.ads (working copy) @@ -46,6 +46,14 @@ -- order is specified and there is at least one component clause. Adjusts -- component positions according to either Ada 95 or Ada 2005 (AI-133). + function Build_Invariant_Procedure_Declaration + (Typ : Entity_Id) return Node_Id; + -- If a type declaration has a specified invariant aspect, build the + -- declaration for the procedure at once, so that calls to it can be + -- generated before the body of the invariant procedure is built. This + -- is needed in the presence of public expression functions that return + -- the type in question. + procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id); -- Typ is a private type with invariants (indicated by Has_Invariants being -- set for Typ, indicating the presence of pragma Invariant entries on the