From patchwork Thu Apr 11 10:45:22 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 235698 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]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 93FAD2C00A2 for ; Thu, 11 Apr 2013 20:45:36 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=TjsViKcGFop6aQeAkalyPzCxr5TelXMEKkGVESYnys0GsTrdWZ HHlE+3O6GrJ1BI5fRf4BzTFNgTSrYfIHksz3JNypIlhmF6MAT+nidody7UxaY+IF enJ5Ja9Rl9G0ZfLpoqoL1TIRH6v6UszUF7bmuikMFkAERp1muhL3Hdxxs= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=7J3A22bn387gLpFURr+hS4F4qSU=; b=W+aPuhaTO+EkQ8bXpOqW Jq0jXf7OrlpxkXKM+QhhDbtTWpXlSFVhhj8EYAtoXtS46duDdBGdI/TM2Voal0XK Yo4I5xWk1xq3NC3PrEsxlx6yngSX1a0vczaW8yd9hEOBUbCe/7TLW7uwgdVkwsRk V/yZxgwwIKGuZIhxKud8paU= Received: (qmail 772 invoked by alias); 11 Apr 2013 10:45:28 -0000 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 Received: (qmail 761 invoked by uid 89); 11 Apr 2013 10:45:28 -0000 X-Spam-SWARE-Status: No, score=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO autolearn=ham version=3.3.1 Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Thu, 11 Apr 2013 10:45:25 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 19BF52EA8A; Thu, 11 Apr 2013 06:45:23 -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 4giHyxLMKY3n; Thu, 11 Apr 2013 06:45:23 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id D6C4B2E123; Thu, 11 Apr 2013 06:45:22 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id D5DA53FF09; Thu, 11 Apr 2013 06:45:22 -0400 (EDT) Date: Thu, 11 Apr 2013 06:45:22 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Raise_Expression in membership test causes test to fail Message-ID: <20130411104522.GA17134@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) X-Virus-Found: No This patch implements Ada 2012 AI-0022, which specifies that a raise expression that is executed in a predicate that is tested during the execution of a membership test causes the test to fail (or succeed for NOT IN), rather than raising an exception. The following, compiled with -gnata: 1. pragma Ada_2012; 2. with Text_IO; use Text_IO; 3. procedure RaiseEXMem is 4. function Is_Gnarly (X : Integer) return Boolean is 5. begin 6. return X > 20; 7. end Is_Gnarly; 8. 9. subtype S is Integer with 10. Dynamic_Predicate => Is_Gnarly (S) 11. or else raise Program_Error; 12. 13. begin 14. if 10 in S then 15. Put_Line ("predicate was true (unexpected)!"); 16. else 17. Put_Line ("predicate was false as expected!"); 18. end if; 19. 20. if 42 in S then 21. Put_Line ("predicate was true as expected!"); 22. else 23. Put_Line ("predicate was false (unexpected)!"); 24. end if; 25. 26. 27. exception 28. when others => 29. Put_Line ("unexpected exception was raised"); 30. end RaiseEXMem; prints out predicate was false as expected! predicate was true as expected! Tested on x86_64-pc-linux-gnu, committed on trunk 2013-04-11 Robert Dewar * atree.h: Add declarations for Flag255-Flag289 Fix declaration of Field30 (was wrong, but no effect, since not yet referenced by back end) Add declarations for Field31-Field35 Add declarations for Node31-Node35. * einfo.ads, einfo.adb (Has_Invariants): No longer applies to procedures. (Has_Predicates): No longer applies to functions. (Is_Predicate_Function): New flag. (Is_Predicate_Function_M): New flag. (Is_Invariant_Procedure): New flag. (Predicate_Function_M): New function. (Set_Predicate_Function_M): New procedure. * exp_ch11.adb (Expand_N_Raise_Expression): Take care of special case of appearing in predicate used for membership test. * exp_ch3.adb (Insert_Component_Invariant_Checks): Set Is_Invariant_Procedure flag. * exp_ch4.adb (Expand_Op_In): Call special predicate function that takes care of raise_expression nodes in the predicate. * exp_util.ads, exp_util.adb (Make_Predicate_Call): Add argument Mem for membership case. * sem_ch13.adb (Build_Predicate_Functions): New name for Build_Predicate_Function. Major rewrite to take care of raise expression in predicate for membership tests. * sem_res.adb (Resolve_Actuals): Include both predicate functions in defense against infinite predicate function loops. * sinfo.ads, sinfo.adb (Convert_To_Return_False): New flag. Index: exp_util.adb =================================================================== --- exp_util.adb (revision 197764) +++ exp_util.adb (working copy) @@ -5520,18 +5520,36 @@ function Make_Predicate_Call (Typ : Entity_Id; - Expr : Node_Id) return Node_Id + Expr : Node_Id; + Mem : Boolean := False) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); begin pragma Assert (Present (Predicate_Function (Typ))); + -- Call special membership version if requested and available + + if Mem then + declare + PFM : constant Entity_Id := Predicate_Function_M (Typ); + begin + if Present (PFM) then + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (PFM, Loc), + Parameter_Associations => New_List (Relocate_Node (Expr))); + end if; + end; + end if; + + -- Case of calling normal predicate function + return - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (Predicate_Function (Typ), Loc), - Parameter_Associations => New_List (Relocate_Node (Expr))); + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Predicate_Function (Typ), Loc), + Parameter_Associations => New_List (Relocate_Node (Expr))); end Make_Predicate_Call; -------------------------- Index: exp_util.ads =================================================================== --- exp_util.ads (revision 197743) +++ exp_util.ads (working copy) @@ -647,9 +647,12 @@ function Make_Predicate_Call (Typ : Entity_Id; - Expr : Node_Id) return Node_Id; + Expr : Node_Id; + Mem : Boolean := False) return Node_Id; -- Typ is a type with Predicate_Function set. This routine builds a call to -- this function passing Expr as the argument, and returns it unanalyzed. + -- If Mem is set True, this is the special call for the membership case, + -- and the function called is the Predicate_Function_M if present. function Make_Predicate_Check (Typ : Entity_Id; Index: sinfo.adb =================================================================== --- sinfo.adb (revision 197764) +++ sinfo.adb (working copy) @@ -602,6 +602,14 @@ return Flag14 (N); end Conversion_OK; + function Convert_To_Return_False + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Expression); + return Flag13 (N); + end Convert_To_Return_False; + function Corresponding_Aspect (N : Node_Id) return Node_Id is begin @@ -3685,6 +3693,14 @@ Set_Flag14 (N, Val); end Set_Conversion_OK; + procedure Set_Convert_To_Return_False + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Expression); + Set_Flag13 (N, Val); + end Set_Convert_To_Return_False; + procedure Set_Corresponding_Aspect (N : Node_Id; Val : Node_Id) is begin Index: sinfo.ads =================================================================== --- sinfo.ads (revision 197764) +++ sinfo.ads (working copy) @@ -720,6 +720,12 @@ -- direct conversion of the underlying integer result, with no regard to -- the small operand. + -- Convert_To_Return_False (Flag13-Sem) + -- Present in N_Raise_Expression nodes that appear in the body of the + -- special predicateM function used to test a predicate in the context + -- of a membership test, where raise expression results in returning a + -- value of False rather than raising an exception. + -- Corresponding_Aspect (Node3-Sem) -- Present in N_Pragma node. Used to point back to the source aspect from -- the corresponding pragma. This field is Empty for source pragmas. @@ -6139,6 +6145,7 @@ -- Sloc points to RAISE -- Name (Node2) (always present) -- Expression (Node3) (set to Empty if no expression present) + -- Convert_To_Return_False (Flag13-Sem) -- plus fields for expression ------------------------------- @@ -8299,6 +8306,9 @@ function Conversion_OK (N : Node_Id) return Boolean; -- Flag14 + function Convert_To_Return_False + (N : Node_Id) return Boolean; -- Flag13 + function Corresponding_Aspect (N : Node_Id) return Node_Id; -- Node3 @@ -9280,6 +9290,9 @@ procedure Set_Conversion_OK (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Convert_To_Return_False + (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Corresponding_Aspect (N : Node_Id; Val : Node_Id); -- Node3 @@ -11880,6 +11893,7 @@ pragma Inline (Context_Items); pragma Inline (Context_Pending); pragma Inline (Controlling_Argument); + pragma Inline (Convert_To_Return_False); pragma Inline (Conversion_OK); pragma Inline (Corresponding_Aspect); pragma Inline (Corresponding_Body); @@ -12204,6 +12218,7 @@ pragma Inline (Set_Context_Items); pragma Inline (Set_Context_Pending); pragma Inline (Set_Controlling_Argument); + pragma Inline (Set_Convert_To_Return_False); pragma Inline (Set_Conversion_OK); pragma Inline (Set_Corresponding_Aspect); pragma Inline (Set_Corresponding_Body); Index: einfo.adb =================================================================== --- einfo.adb (revision 197743) +++ einfo.adb (working copy) @@ -542,10 +542,10 @@ -- Is_Processed_Transient Flag252 -- Has_Anonymous_Master Flag253 -- Is_Implementation_Defined Flag254 + -- Is_Predicate_Function Flag255 + -- Is_Predicate_Function_M Flag256 + -- Is_Invariant_Procedure Flag257 - -- (unused) Flag255 - -- (unused) Flag256 - -- (unused) Flag257 -- (unused) Flag258 -- (unused) Flag259 -- (unused) Flag260 @@ -578,41 +578,9 @@ -- (unused) Flag284 -- (unused) Flag285 -- (unused) Flag286 - -- (unused) Flag287 - -- (unused) Flag288 - -- (unused) Flag289 - -- (unused) Flag290 - -- (unused) Flag291 - -- (unused) Flag292 - -- (unused) Flag293 - -- (unused) Flag294 - -- (unused) Flag295 - -- (unused) Flag296 - -- (unused) Flag297 - -- (unused) Flag298 - -- (unused) Flag299 - -- (unused) Flag300 + -- Note: Flag287-317 are defined in atree.ads/adb, but not yet in atree.h - -- (unused) Flag301 - -- (unused) Flag302 - -- (unused) Flag303 - -- (unused) Flag304 - -- (unused) Flag305 - -- (unused) Flag306 - -- (unused) Flag307 - -- (unused) Flag308 - -- (unused) Flag309 - -- (unused) Flag310 - - -- (unused) Flag311 - -- (unused) Flag312 - -- (unused) Flag313 - -- (unused) Flag314 - -- (unused) Flag315 - -- (unused) Flag316 - -- (unused) Flag317 - ----------------------- -- Local subprograms -- ----------------------- @@ -1488,9 +1456,7 @@ function Has_Invariants (Id : E) return B is begin - pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Procedure - or else Ekind (Id) = E_Generic_Procedure); + pragma Assert (Is_Type (Id)); return Flag232 (Id); end Has_Invariants; @@ -1614,6 +1580,7 @@ function Has_Predicates (Id : E) return B is begin + pragma Assert (Is_Type (Id)); return Flag250 (Id); end Has_Predicates; @@ -2076,6 +2043,12 @@ return Flag64 (Id); end Is_Intrinsic_Subprogram; + function Is_Invariant_Procedure (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Flag257 (Id); + end Is_Invariant_Procedure; + function Is_Itype (Id : E) return B is begin return Flag91 (Id); @@ -2167,6 +2140,18 @@ return Flag9 (Id); end Is_Potentially_Use_Visible; + function Is_Predicate_Function (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Flag255 (Id); + end Is_Predicate_Function; + + function Is_Predicate_Function_M (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Flag256 (Id); + end Is_Predicate_Function_M; + function Is_Preelaborated (Id : E) return B is begin return Flag59 (Id); @@ -4037,9 +4022,7 @@ procedure Set_Has_Invariants (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Procedure - or else Ekind (Id) = E_Void); + pragma Assert (Is_Type (Id)); Set_Flag232 (Id, V); end Set_Has_Invariants; @@ -4172,6 +4155,7 @@ procedure Set_Has_Predicates (Id : E; V : B := True) is begin + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Void); Set_Flag250 (Id, V); end Set_Has_Predicates; @@ -4658,6 +4642,12 @@ Set_Flag64 (Id, V); end Set_Is_Intrinsic_Subprogram; + procedure Set_Is_Invariant_Procedure (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Flag257 (Id, V); + end Set_Is_Invariant_Procedure; + procedure Set_Is_Itype (Id : E; V : B := True) is begin Set_Flag91 (Id, V); @@ -4752,6 +4742,18 @@ Set_Flag9 (Id, V); end Set_Is_Potentially_Use_Visible; + procedure Set_Is_Predicate_Function (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Flag255 (Id, V); + end Set_Is_Predicate_Function; + + procedure Set_Is_Predicate_Function_M (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Flag256 (Id, V); + end Set_Is_Predicate_Function_M; + procedure Set_Is_Preelaborated (Id : E; V : B := True) is begin Set_Flag59 (Id, V); @@ -6403,7 +6405,7 @@ else S := Subprograms_For_Type (Id); while Present (S) loop - if Has_Invariants (S) then + if Is_Invariant_Procedure (S) then return S; else S := Subprograms_For_Type (S); @@ -7121,7 +7123,7 @@ else S := Subprograms_For_Type (Id); while Present (S) loop - if Has_Predicates (S) then + if Is_Predicate_Function (S) then return S; else S := Subprograms_For_Type (S); @@ -7132,6 +7134,33 @@ end if; end Predicate_Function; + -------------------------- + -- Predicate_Function_M -- + -------------------------- + + function Predicate_Function_M (Id : E) return E is + S : Entity_Id; + + begin + pragma Assert (Is_Type (Id)); + + if No (Subprograms_For_Type (Id)) then + return Empty; + + else + S := Subprograms_For_Type (Id); + while Present (S) loop + if Is_Predicate_Function_M (S) then + return S; + else + S := Subprograms_For_Type (S); + end if; + end loop; + + return Empty; + end if; + end Predicate_Function_M; + ------------------------- -- Present_In_Rep_Item -- ------------------------- @@ -7365,8 +7394,10 @@ Set_Subprograms_For_Type (Id, V); Set_Subprograms_For_Type (V, S); + -- Check for duplicate entry + while Present (S) loop - if Has_Invariants (S) then + if Is_Invariant_Procedure (S) then raise Program_Error; else S := Subprograms_For_Type (S); @@ -7389,7 +7420,7 @@ Set_Subprograms_For_Type (V, S); while Present (S) loop - if Has_Predicates (S) then + if Is_Predicate_Function (S) then raise Program_Error; else S := Subprograms_For_Type (S); @@ -7397,6 +7428,31 @@ end loop; end Set_Predicate_Function; + ------------------------------ + -- Set_Predicate_Function_M -- + ------------------------------ + + procedure Set_Predicate_Function_M (Id : E; V : E) is + S : Entity_Id; + + begin + pragma Assert (Is_Type (Id) and then Has_Predicates (Id)); + + S := Subprograms_For_Type (Id); + Set_Subprograms_For_Type (Id, V); + Set_Subprograms_For_Type (V, S); + + -- Check for duplicates + + while Present (S) loop + if Is_Predicate_Function_M (S) then + raise Program_Error; + else + S := Subprograms_For_Type (S); + end if; + end loop; + end Set_Predicate_Function_M; + ----------------- -- Size_Clause -- ----------------- @@ -7783,6 +7839,7 @@ W ("Is_Internal", Flag17 (Id)); W ("Is_Interrupt_Handler", Flag89 (Id)); W ("Is_Intrinsic_Subprogram", Flag64 (Id)); + W ("Is_Invariant_Procedure", Flag257 (Id)); W ("Is_Itype", Flag91 (Id)); W ("Is_Known_Non_Null", Flag37 (Id)); W ("Is_Known_Null", Flag204 (Id)); @@ -7800,6 +7857,8 @@ W ("Is_Packed", Flag51 (Id)); W ("Is_Packed_Array_Type", Flag138 (Id)); W ("Is_Potentially_Use_Visible", Flag9 (Id)); + W ("Is_Predicate_Function", Flag255 (Id)); + W ("Is_Predicate_Function_M", Flag256 (Id)); W ("Is_Preelaborated", Flag59 (Id)); W ("Is_Primitive", Flag218 (Id)); W ("Is_Primitive_Wrapper", Flag195 (Id)); Index: einfo.ads =================================================================== --- einfo.ads (revision 197743) +++ einfo.ads (working copy) @@ -1587,9 +1587,7 @@ -- True, then usually the Invariant_Procedure attribute is set once the -- type is frozen, however this may not be true in some error situations. -- Note that it might be the full type which has inheritable invariants, --- and then the flag will also be set in the private type. Also set in --- the invariant procedure entity, to distinguish it among entries in the --- Subprograms_For_Type. +-- and then the flag will also be set in the private type. -- Has_Machine_Radix_Clause (Flag83) -- Defined in decimal types and subtypes, set if a Machine_Radix @@ -1731,11 +1729,9 @@ -- such an object and no warning is generated. -- Has_Predicates (Flag250) --- Defined 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. +-- Defined in type and subtype entities. Set if a pragma Predicate or +-- Predicate aspect applies to the type or subtype, or if it inherits a +-- Predicate aspect from its parent or progenitor types. -- Has_Primitive_Operations (Flag120) [base type only] -- Defined in all type entities. Set if at least one primitive operation @@ -2406,6 +2402,10 @@ -- setting of Is_Intrinsic_Subprogram, NOT simply having convention set -- to intrinsic, which causes intrinsic code to be generated. +-- Is_Invariant_Procedure (Flag257) +-- Defined in functions an procedures. Set for a generated invariant +-- procedure to identify it easily in the + -- Is_Itype (Flag91) -- Defined in all entities. Set to indicate that a type is an Itype, -- which means that the declaration for the type does not appear @@ -2637,6 +2637,15 @@ -- use clause (RM 8.4(8)). Note that potentially use visible entities -- are not necessarily use visible (RM 8.4(9-11)). +-- Is_Predicate_Function (Flag255) +-- Present in functions and procedures. Set for generated predicate +-- functions. + +-- Is_Predicate_Function_M (Flag256) +-- Present in functions and procedures. Set for special version of +-- predicate function generated for use in membership tests, where +-- raise expressions are transformed to return False. + -- Is_Preelaborated (Flag59) -- Defined in all entities, set in E_Package and E_Generic_Package -- entities to which a pragma Preelaborate is applied, and also in @@ -3384,6 +3393,12 @@ -- Note: the reason this is marked as a synthesized attribute is that the -- way this is stored is as an element of the Subprograms_For_Type field. +-- Predicate_Function_M (synthesized) +-- Defined in all types. Present only if Predicate_Function is present, +-- and only if the predicate function has Raise_Expression nodes. It +-- is the special version created for membership tests, where if one of +-- these raise expressions is executed, the result is to return False. + -- Primitive_Operations (synthesized) -- Defined in concurrent types, tagged record types and subtypes, tagged -- private types and tagged incomplete types. For concurrent types whose @@ -4844,7 +4859,6 @@ -- 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) @@ -4961,6 +4975,7 @@ -- 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) @@ -5006,6 +5021,7 @@ -- Invariant_Procedure (synth) -- Is_Access_Protected_Subprogram_Type (synth) -- Predicate_Function (synth) + -- Predicate_Function_M (synth) -- Root_Type (synth) -- Size_Clause (synth) @@ -5360,7 +5376,10 @@ -- Is_Eliminated (Flag124) -- Is_Instantiated (Flag126) (generic case only) -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Invariant_Procedure (Flag257) (non-generic case only) -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) + -- Is_Predicate_Function (Flag255) (non-generic case only) + -- Is_Predicate_Function_M (Flag256) (non-generic case only) -- Is_Primitive (Flag218) -- Is_Primitive_Wrapper (Flag195) (non-generic case only) -- Is_Private_Descendant (Flag53) @@ -5629,8 +5648,11 @@ -- Is_Instantiated (Flag126) (generic case only) -- Is_Interrupt_Handler (Flag89) -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Invariant_Procedure (Flag257) (non-generic case only) -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) -- Is_Null_Init_Proc (Flag178) + -- Is_Predicate_Function (Flag255) (non-generic case only) + -- Is_Predicate_Function_M (Flag256) (non-generic case only) -- Is_Primitive (Flag218) -- Is_Primitive_Wrapper (Flag195) (non-generic case only) -- Is_Private_Descendant (Flag53) @@ -6327,6 +6349,7 @@ function Is_Internal (Id : E) return B; function Is_Interrupt_Handler (Id : E) return B; function Is_Intrinsic_Subprogram (Id : E) return B; + function Is_Invariant_Procedure (Id : E) return B; function Is_Itype (Id : E) return B; function Is_Known_Non_Null (Id : E) return B; function Is_Known_Null (Id : E) return B; @@ -6344,6 +6367,8 @@ function Is_Packed (Id : E) return B; function Is_Packed_Array_Type (Id : E) return B; function Is_Potentially_Use_Visible (Id : E) return B; + function Is_Predicate_Function (Id : E) return B; + function Is_Predicate_Function_M (Id : E) return B; function Is_Preelaborated (Id : E) return B; function Is_Primitive (Id : E) return B; function Is_Primitive_Wrapper (Id : E) return B; @@ -6933,6 +6958,7 @@ procedure Set_Is_Internal (Id : E; V : B := True); procedure Set_Is_Interrupt_Handler (Id : E; V : B := True); procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True); + procedure Set_Is_Invariant_Procedure (Id : E; V : B := True); procedure Set_Is_Itype (Id : E; V : B := True); procedure Set_Is_Known_Non_Null (Id : E; V : B := True); procedure Set_Is_Known_Null (Id : E; V : B := True); @@ -6951,6 +6977,8 @@ procedure Set_Is_Packed (Id : E; V : B := True); procedure Set_Is_Packed_Array_Type (Id : E; V : B := True); procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); + procedure Set_Is_Predicate_Function (Id : E; V : B := True); + procedure Set_Is_Predicate_Function_M (Id : E; V : B := True); procedure Set_Is_Preelaborated (Id : E; V : B := True); procedure Set_Is_Primitive (Id : E; V : B := True); procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); @@ -7104,9 +7132,11 @@ function Invariant_Procedure (Id : E) return N; function Predicate_Function (Id : E) return N; + function Predicate_Function_M (Id : E) return N; procedure Set_Invariant_Procedure (Id : E; V : E); procedure Set_Predicate_Function (Id : E; V : E); + procedure Set_Predicate_Function_M (Id : E; V : E); ----------------------------------- -- Field Initialization Routines -- @@ -7649,6 +7679,7 @@ pragma Inline (Is_Internal); pragma Inline (Is_Interrupt_Handler); pragma Inline (Is_Intrinsic_Subprogram); + pragma Inline (Is_Invariant_Procedure); pragma Inline (Is_Itype); pragma Inline (Is_Known_Non_Null); pragma Inline (Is_Known_Null); @@ -7673,6 +7704,8 @@ pragma Inline (Is_Packed); pragma Inline (Is_Packed_Array_Type); pragma Inline (Is_Potentially_Use_Visible); + pragma Inline (Is_Predicate_Function); + pragma Inline (Is_Predicate_Function_M); pragma Inline (Is_Preelaborated); pragma Inline (Is_Primitive); pragma Inline (Is_Primitive_Wrapper); @@ -8074,6 +8107,7 @@ pragma Inline (Set_Is_Internal); pragma Inline (Set_Is_Interrupt_Handler); pragma Inline (Set_Is_Intrinsic_Subprogram); + pragma Inline (Set_Is_Invariant_Procedure); pragma Inline (Set_Is_Itype); pragma Inline (Set_Is_Known_Non_Null); pragma Inline (Set_Is_Known_Null); @@ -8092,6 +8126,8 @@ pragma Inline (Set_Is_Packed); pragma Inline (Set_Is_Packed_Array_Type); pragma Inline (Set_Is_Potentially_Use_Visible); + pragma Inline (Set_Is_Predicate_Function); + pragma Inline (Set_Is_Predicate_Function_M); pragma Inline (Set_Is_Preelaborated); pragma Inline (Set_Is_Primitive); pragma Inline (Set_Is_Primitive_Wrapper); Index: sem_res.adb =================================================================== --- sem_res.adb (revision 197764) +++ sem_res.adb (working copy) @@ -3935,7 +3935,9 @@ -- infinite recursion. if not (Ekind (Nam) = E_Function - and then Has_Predicates (Nam)) + and then (Is_Predicate_Function (Nam) + or else + Is_Predicate_Function_M (Nam))) then Apply_Predicate_Check (A, F_Typ); end if; @@ -9792,7 +9794,9 @@ if Has_Predicates (Target_Typ) then if Nkind (Parent (N)) = N_Function_Call and then Present (Name (Parent (N))) - and then Has_Predicates (Entity (Name (Parent (N)))) + and then (Is_Predicate_Function (Entity (Name (Parent (N)))) + or else + Is_Predicate_Function_M (Entity (Name (Parent (N))))) then null; Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 197762) +++ exp_ch4.adb (working copy) @@ -6338,7 +6338,7 @@ Rewrite (N, Make_And_Then (Loc, Left_Opnd => Relocate_Node (N), - Right_Opnd => Make_Predicate_Call (Rtyp, Lop))); + Right_Opnd => Make_Predicate_Call (Rtyp, Lop, Mem => True))); -- Analyze new expression, mark left operand as analyzed to -- avoid infinite recursion adding predicate calls. Similarly, Index: exp_ch11.adb =================================================================== --- exp_ch11.adb (revision 197764) +++ exp_ch11.adb (working copy) @@ -1450,22 +1450,40 @@ -- do -- raise X [with string] -- in - -- raise Consraint_Error; + -- raise Constraint_Error; + -- unless the flag Convert_To_Return_False is set, in which case + -- the transformation is to: + + -- do + -- return False; + -- in + -- raise Constraint_Error; + -- The raise constraint error can never be executed. It is just a dummy -- node that can be labeled with an arbitrary type. RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise); Set_Etype (RCE, Typ); - Rewrite (N, - Make_Expression_With_Actions (Loc, - Actions => New_List ( - Make_Raise_Statement (Loc, - Name => Name (N), - Expression => Expression (N))), - Expression => RCE)); + if Convert_To_Return_False (N) then + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc))), + Expression => RCE)); + else + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => New_List ( + Make_Raise_Statement (Loc, + Name => Name (N), + Expression => Expression (N))), + Expression => RCE)); + end if; + Analyze_And_Resolve (N, Typ); end Expand_N_Raise_Expression; Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 197752) +++ sem_ch13.adb (working copy) @@ -82,7 +82,7 @@ -- type whose inherited alignment is no longer appropriate for the new -- size value. In this case, we reset the Alignment to unknown. - procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id); + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); -- If Typ has predicates (indicated by Has_Predicates being set for Typ, -- then either there are pragma Predicate entries on the rep chain for the -- type (note that Predicate aspects are converted to pragma Predicate), or @@ -90,7 +90,9 @@ -- This procedure builds the spec and body for the Predicate function that -- tests these predicates. N is the freeze node for the type. The spec of -- the function is inserted before the freeze node, and the body of the - -- function is inserted after the freeze node. + -- function is inserted after the freeze node. If the predicate expression + -- has at least one Raise_Expression, then this procedure also builds the + -- M version of the predicate function for ue in membership tests. procedure Build_Static_Predicate (Typ : Entity_Id; @@ -4689,12 +4691,12 @@ -- If we have a type with predicates, build predicate function if Is_Type (E) and then Has_Predicates (E) then - Build_Predicate_Function (E, N); + Build_Predicate_Functions (E, N); end if; -- If type has delayed aspects, this is where we do the preanalysis at -- the freeze point, as part of the consistent visibility check. Note - -- that this must be done after calling Build_Predicate_Function or + -- that this must be done after calling Build_Predicate_Functions or -- Build_Invariant_Procedure since these subprograms fix occurrences of -- the subtype name in the saved expression so that they will not cause -- trouble in the preanalysis. @@ -5225,9 +5227,9 @@ 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_Is_Invariant_Procedure (SId); Set_Invariant_Procedure (Typ, SId); Spec := @@ -5597,11 +5599,11 @@ end if; end Build_Invariant_Procedure; - ------------------------------ - -- Build_Predicate_Function -- - ------------------------------ + ------------------------------- + -- Build_Predicate_Functions -- + ------------------------------- - -- The procedure that is constructed here has the form: + -- The procedures that are constructed here has the form: -- function typPredicate (Ixxx : typ) return Boolean is -- begin @@ -5618,17 +5620,38 @@ -- inherited. Note that we do NOT generate Check pragmas, that's because we -- use this function even if checks are off, e.g. for membership tests. - procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is - Loc : constant Source_Ptr := Sloc (Typ); - Spec : Node_Id; - SId : Entity_Id; - FDecl : Node_Id; - FBody : Node_Id; + -- If the expression has at least one Raise_Expression, then we also build + -- the typPredicateM version of the function, in which any occurence of a + -- Raise_Expressioon is converted to "return False". + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Expr : Node_Id; - -- This is the expression for the return statement in the function. It + -- This is the expression for the result of the function. It is -- is build by connecting the component predicates with AND THEN. + Expr_M : Node_Id; + -- This is the corresponding return expression for the Predicate_M + -- function. It differs in that raise expressions are marked for + -- special expansion (see Process_REs). + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of Predicate procedure. Note that we use the same + -- name for both predicate procedure. That way the reference within the + -- predicate expression is the same in both functions. + + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Entity for argument of Predicate procedure + + Object_Entity_M : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Entity for argument of Predicate_M procedure + + Raise_Expression_Present : Boolean := False; + -- Set True if Expr has at least one Raise_Expression + procedure Add_Call (T : Entity_Id); -- Includes a call to the predicate function for type T in Expr if T -- has predicates and Predicate_Function (T) is non-empty. @@ -5639,13 +5662,20 @@ -- Inheritance of predicates for the parent type is done by calling the -- Predicate_Function of the parent type, using Add_Call above. - Object_Name : constant Name_Id := New_Internal_Name ('I'); - -- Name for argument of Predicate procedure + function Test_RE (N : Node_Id) return Traverse_Result; + -- Used in Test_REs, tests one node for being a raise expression, and if + -- so sets Raise_Expression_Present True. - Object_Entity : constant Entity_Id := - Make_Defining_Identifier (Loc, Object_Name); - -- The entity for the spec entity for the argument + procedure Test_REs is new Traverse_Proc (Test_RE); + -- Tests to see if Expr contains any raise expressions + function Process_RE (N : Node_Id) return Traverse_Result; + -- Used in Process REs, tests if node N is a raise expression, and if + -- so, marks it to be converted to return False. + + procedure Process_REs is new Traverse_Proc (Process_RE); + -- Marks any raise expressions in Expr_M to return False + Dynamic_Predicate_Present : Boolean := False; -- Set True if a dynamic predicate is present, results in the entire -- predicate being considered dynamic even if it looks static @@ -5730,8 +5760,8 @@ Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); -- Use the Sloc of the usage name, not the defining name + Set_Etype (N, Typ); Set_Entity (N, Object_Entity); - Set_Etype (N, Typ); -- We want to treat the node as if it comes from source, so that -- ASIS will not ignore it @@ -5830,13 +5860,37 @@ end loop; end Add_Predicates; - -- Start of processing for Build_Predicate_Function + ---------------- + -- Process_RE -- + ---------------- - begin - -- Initialize for construction of statement list + function Process_RE (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Raise_Expression then + Set_Convert_To_Return_False (N); + return Skip; + else + return OK; + end if; + end Process_RE; - Expr := Empty; + ------------- + -- Test_RE -- + ------------- + function Test_RE (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Raise_Expression then + Raise_Expression_Present := True; + return Abandon; + else + return OK; + end if; + end Test_RE; + + -- Start of processing for Build_Predicate_Functions + + begin -- Return if already built or if type does not have predicates if not Has_Predicates (Typ) @@ -5845,6 +5899,10 @@ return; end if; + -- Prepare to construct predicate expression + + Expr := Empty; + -- Add Predicates for the current type Add_Predicates; @@ -5859,70 +5917,199 @@ end if; end; - -- If we have predicates, build the function + -- Case where predicates are present if Present (Expr) then - -- Build function declaration + -- Test for raise expression present - SId := - 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); + Test_REs (Expr); - -- The predicate function is shared between views of a type. + -- If raise expression is present, capture a copy of Expr for use + -- in building the predicateM function version later on. For this + -- copy we replace references to Object_Entity by Object_Entity_M. - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Set_Predicate_Function (Full_View (Typ), SId); + if Raise_Expression_Present then + declare + Map : constant Elist_Id := New_Elmt_List; + begin + Append_Elmt (Object_Entity, Map); + Append_Elmt (Object_Entity_M, Map); + Expr_M := New_Copy_Tree (Expr, Map => Map); + end; end if; - Spec := - Make_Function_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))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + -- Build the main predicate function - FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); + declare + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + -- The entity for the the function spec - -- Build function body + SIdB : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + -- The entity for the function body - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); + Spec : Node_Id; + FDecl : Node_Id; + FBody : Node_Id; - Spec := - Make_Function_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))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + begin + -- Build function declaration - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Expr)))); + Set_Ekind (SId, E_Function); + Set_Is_Predicate_Function (SId); + Set_Predicate_Function (Typ, SId); - -- Insert declaration before freeze node and body after + -- The predicate function is shared between views of a type - Insert_Before_And_Analyze (N, FDecl); - Insert_After_And_Analyze (N, FBody); + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Set_Predicate_Function (Full_View (Typ), SId); + end if; + Spec := + Make_Function_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))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); + + -- Insert declaration before freeze node and body after + + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); + end; + + -- Test for raise expressions present and if so build M version + + if Raise_Expression_Present then + declare + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "PredicateM")); + -- The entity for the the function spec + + SIdB : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "PredicateM")); + -- The entity for the function body + + Spec : Node_Id; + FDecl : Node_Id; + FBody : Node_Id; + BTemp : Entity_Id; + + begin + -- Mark any raise expressions for special expansion + + Process_REs (Expr_M); + + -- Build function declaration + + Set_Ekind (SId, E_Function); + Set_Is_Predicate_Function_M (SId); + Set_Predicate_Function_M (Typ, SId); + + -- The predicate function is shared between views of a type + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Set_Predicate_Function_M (Full_View (Typ), SId); + end if; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity_M, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + -- Build the body, we declare the boolean expression before + -- doing the return, because we are not really confident of + -- what happens if a return appears within a return! + + BTemp := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('B')); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => BTemp, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => Expr_M)), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (BTemp, Loc))))); + + -- Insert declaration before freeze node and body after + + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); + end; + end if; + -- Deal with static predicate case if Ekind_In (Typ, E_Enumeration_Subtype, @@ -5944,7 +6131,7 @@ end if; end if; end if; - end Build_Predicate_Function; + end Build_Predicate_Functions; ---------------------------- -- Build_Static_Predicate -- @@ -6449,7 +6636,10 @@ declare Ent : constant Entity_Id := Entity (Name (Exp)); begin - if Has_Predicates (Ent) then + if Is_Predicate_Function (Ent) + or else + Is_Predicate_Function_M (Ent) + then return Stat_Pred (Etype (First_Formal (Ent))); end if; end; Index: atree.h =================================================================== --- atree.h (revision 197743) +++ atree.h (working copy) @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2013, 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- * @@ -259,6 +259,45 @@ Boolean flag215 : 1; }; +/* Structure used for extra flags in sixth component overlaying Field12 */ +struct Flag_Word5 +{ + Boolean flag255 : 1; + Boolean flag256 : 1; + Boolean flag257 : 1; + Boolean flag258 : 1; + Boolean flag259 : 1; + Boolean flag260 : 1; + Boolean flag261 : 1; + Boolean flag262 : 1; + + Boolean flag263 : 1; + Boolean flag264 : 1; + Boolean flag265 : 1; + Boolean flag266 : 1; + Boolean flag267 : 1; + Boolean flag268 : 1; + Boolean flag269 : 1; + Boolean flag270 : 1; + + Boolean flag271 : 1; + Boolean flag272 : 1; + Boolean flag273 : 1; + Boolean flag274 : 1; + Boolean flag275 : 1; + Boolean flag276 : 1; + Boolean flag277 : 1; + Boolean flag278 : 1; + + Boolean flag279 : 1; + Boolean flag280 : 1; + Boolean flag281 : 1; + Boolean flag282 : 1; + Boolean flag283 : 1; + Boolean flag284 : 1; + Boolean flag285 : 1; + Boolean flag286 : 1; +}; struct Non_Extended { Source_Ptr sloc; @@ -290,6 +329,7 @@ struct Flag_Word fw; struct Flag_Word2 fw2; struct Flag_Word4 fw4; + struct Flag_Word5 fw5; } U; }; @@ -387,7 +427,12 @@ #define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9) #define Field28(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field10) #define Field29(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.field11) -#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6) +#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field6) +#define Field31(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field7) +#define Field32(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field8) +#define Field33(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field9) +#define Field34(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field10) +#define Field35(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.X.field11) #define Node1(N) Field1 (N) #define Node2(N) Field2 (N) @@ -419,6 +464,12 @@ #define Node28(N) Field28 (N) #define Node29(N) Field29 (N) #define Node30(N) Field30 (N) +#define Node31(N) Field31 (N) +#define Node32(N) Field32 (N) +#define Node33(N) Field33 (N) +#define Node34(N) Field34 (N) +#define Node35(N) Field35 (N) +#define Node36(N) Field36 (N) #define List1(N) Field1 (N) #define List2(N) Field2 (N) @@ -742,6 +793,39 @@ #define Flag253(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag71) #define Flag254(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag72) +#define Flag255(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag255) +#define Flag256(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag256) +#define Flag257(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag257) +#define Flag258(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag258) +#define Flag259(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag259) +#define Flag260(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag260) +#define Flag261(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag261) +#define Flag262(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag262) +#define Flag263(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag263) +#define Flag264(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag264) +#define Flag265(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag265) +#define Flag266(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag266) +#define Flag267(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag267) +#define Flag268(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag268) +#define Flag269(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag269) +#define Flag270(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag270) +#define Flag271(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag271) +#define Flag272(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag272) +#define Flag273(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag273) +#define Flag274(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag274) +#define Flag275(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag275) +#define Flag276(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag276) +#define Flag277(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag277) +#define Flag278(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag278) +#define Flag279(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag279) +#define Flag280(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag280) +#define Flag281(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag281) +#define Flag282(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag282) +#define Flag283(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag283) +#define Flag284(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag284) +#define Flag285(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag285) +#define Flag286(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag286) + #ifdef __cplusplus } #endif Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 197743) +++ exp_ch3.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -7675,7 +7675,7 @@ if not Has_Invariants (Typ) then Set_Has_Invariants (Typ); - Set_Has_Invariants (Proc_Id); + Set_Is_Invariant_Procedure (Proc_Id); Set_Invariant_Procedure (Typ, Proc_Id); Insert_After (N, Proc); Analyze (Proc);