From patchwork Thu Oct 21 10:33:50 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68568 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 A9A54B6F0D for ; Thu, 21 Oct 2010 21:34:12 +1100 (EST) Received: (qmail 30773 invoked by alias); 21 Oct 2010 10:34:09 -0000 Received: (qmail 30030 invoked by uid 22791); 21 Oct 2010 10:34:04 -0000 X-SWARE-Spam-Status: No, hits=-1.4 required=5.0 tests=AWL, BAYES_00, TW_TR, 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; Thu, 21 Oct 2010 10:33:53 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 659C3CB0308; Thu, 21 Oct 2010 12:33:50 +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 sKV1ZGsShVh3; Thu, 21 Oct 2010 12:33:50 +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 4D12BCB0304; Thu, 21 Oct 2010 12:33:50 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 2A292D9BB5; Thu, 21 Oct 2010 12:33:50 +0200 (CEST) Date: Thu, 21 Oct 2010 12:33:50 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Next stage in implementing predicate aspect Message-ID: <20101021103350.GA31739@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 is the next stage in the implementation of predicates, not ready for prime time yet. Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-21 Robert Dewar * einfo.ads, einfo.adb: Replace Predicate_Procedure by Predicate_Functions. * exp_ch4.adb (Expand_N_In): Handle predicates. * exp_util.ads, exp_util.adb (Make_Predicate_Call): New function. (Make_Predicate_Check): New function. * freeze.adb (Freee_Entity): Build predicate function if needed. * sem_ch13.adb (Build_Predicate_Function): New procedure. (Analyze_Aspect_Specifications): No third argument for Predicate pragma built from Predicate aspect. * sem_ch13.ads (Build_Predicate_Function): New procedure. * sem_ch3.adb: Add handling for predicates. * sem_eval.adb (Eval_Membership_Op): Never static if predicate functions around. * sem_prag.adb (Analye_Pragma, case Predicate): Does not take a third argument. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165760) +++ sem_ch3.adb (working copy) @@ -484,8 +484,8 @@ package body Sem_Ch3 is -- operations of progenitors of Tagged_Type, and replace the subsidiary -- subtypes with Tagged_Type, to build the specs of the inherited interface -- primitives. The derived primitives are aliased to those of the - -- interface. This routine takes care also of transferring to the full-view - -- subprograms associated with the partial-view of Tagged_Type that cover + -- interface. This routine takes care also of transferring to the full view + -- subprograms associated with the partial view of Tagged_Type that cover -- interface primitives. procedure Derived_Standard_Character @@ -1359,6 +1359,12 @@ package body Sem_Ch3 is pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); + -- This is a reasonable place to propagate predicates + + if Has_Predicates (Iface) then + Set_Has_Predicates (Typ); + end if; + Def := Make_Component_Definition (Loc, Aliased_Present => True, @@ -2300,7 +2306,7 @@ package body Sem_Ch3 is end if; if Etype (T) = Any_Type then - goto Leave; + return; end if; -- Some common processing for all types @@ -2395,8 +2401,9 @@ 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; end Analyze_Full_Type_Declaration; ---------------------------------- @@ -3835,6 +3842,7 @@ package body Sem_Ch3 is Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T)); Set_Is_Ada_2012_Only (Id, Is_Ada_2012_Only (T)); Set_Convention (Id, Convention (T)); + Set_Has_Predicates (Id, Has_Predicates (T)); -- In the case where there is no constraint given in the subtype -- indication, Process_Subtype just returns the Subtype_Mark, so its @@ -7668,6 +7676,12 @@ package body Sem_Ch3 is Set_Has_Invariants (Derived_Type); end if; + -- We similarly inherit predicates + + if Has_Predicates (Parent_Type) then + Set_Has_Predicates (Derived_Type); + end if; + -- The derived type inherits the representation clauses of the parent. -- However, for a private type that is completed by a derivation, there -- may be operation attributes that have been specified already (stream @@ -17186,6 +17200,44 @@ package body Sem_Ch3 is -- Copy Invariant procedure to private declaration Set_Invariant_Procedure (Priv_T, Invariant_Procedure (Full_T)); + Set_Has_Invariants (Priv_T); + end if; + end; + end if; + + -- Propagate predicates to full type, and also build the predicate + -- procedure at this time, in the same way as we did for invariants. + + if Has_Predicates (Priv_T) then + declare + FDecl : Entity_Id; + FBody : Entity_Id; + Packg : constant Node_Id := Declaration_Node (Scope (Priv_T)); + + begin + Build_Predicate_Function (Full_T, FDecl, FBody); + + -- Error defense, normally this should be set + + if Present (FDecl) then + + -- Spec goes at the end of the public part of the package. + -- That's behind us, so we have to manually analyze the + -- inserted spec. + + Append_To (Visible_Declarations (Packg), FDecl); + Analyze (FDecl); + + -- Body goes at the end of the private part of the package. + -- That's ahead of us so it will get analyzed later on when + -- we come to it. + + Append_To (Private_Declarations (Packg), FBody); + + -- Copy Predicate procedure to private declaration + + Set_Predicate_Function (Priv_T, Predicate_Function (Full_T)); + Set_Has_Predicates (Priv_T); end if; end; end if; Index: exp_util.adb =================================================================== --- exp_util.adb (revision 165763) +++ exp_util.adb (working copy) @@ -4086,6 +4086,51 @@ package body Exp_Util is Make_Integer_Literal (Loc, 0)); end Make_Non_Empty_Check; + ------------------------- + -- Make_Predicate_Call -- + ------------------------- + + function Make_Predicate_Call + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + + begin + pragma Assert (Present (Predicate_Function (Typ))); + + return + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Predicate_Function (Typ), Loc), + Parameter_Associations => New_List (Relocate_Node (Expr))); + end Make_Predicate_Call; + + -------------------------- + -- Make_Predicate_Check -- + -------------------------- + + function Make_Predicate_Check + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + + begin + return + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Loc, + Name_Check), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, + Chars => Name_Predicate)), + Make_Pragma_Argument_Association (Loc, + Expression => Make_Predicate_Call (Typ, Expr)))); + end Make_Predicate_Check; + ---------------------------- -- Make_Subtype_From_Expr -- ---------------------------- Index: exp_util.ads =================================================================== --- exp_util.ads (revision 165755) +++ exp_util.ads (working copy) @@ -566,7 +566,21 @@ package Exp_Util is -- Expr is an object of a type which Has_Invariants set (and which thus -- also has an Invariant_Procedure set). If invariants are enabled, this -- function returns a call to the Invariant procedure passing Expr as the - -- argument. + -- argument, and returns it unanalyzed. If invariants are not enabled, + -- returns a null statement. + + function Make_Predicate_Call + (Typ : Entity_Id; + Expr : Node_Id) 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. + + function Make_Predicate_Check + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id; + -- Typ is a type with Predicate_Function set. This routine builds a Check + -- pragma whose first argument is Predicate, and the second argument is a + -- call to the this predicate function with Expr as the argument. function Make_Subtype_From_Expr (E : Node_Id; Index: einfo.adb =================================================================== --- einfo.adb (revision 165763) +++ einfo.adb (working copy) @@ -1411,7 +1411,7 @@ package body Einfo is function Has_Predicates (Id : E) return B is begin - pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure); + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Function); return Flag250 (Id); end Has_Predicates; @@ -3864,7 +3864,7 @@ 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_Procedure + or else Ekind (Id) = E_Function or else Ekind (Id) = E_Void); Set_Flag250 (Id, V); end Set_Has_Predicates; @@ -6265,15 +6265,15 @@ package body Einfo is Ekind (Id) = E_Generic_Package; end Is_Package_Or_Generic_Package; - ------------------------- - -- Predicate_Procedure -- - ------------------------- + ------------------------ + -- Predicate_Function -- + ------------------------ - function Predicate_Procedure (Id : E) return E is + function Predicate_Function (Id : E) return E is S : Entity_Id; begin - pragma Assert (Is_Type (Id) and then Has_Predicates (Id)); + pragma Assert (Is_Type (Id)); if No (Subprograms_For_Type (Id)) then return Empty; @@ -6290,7 +6290,7 @@ package body Einfo is return Empty; end if; - end Predicate_Procedure; + end Predicate_Function; --------------- -- Is_Prival -- @@ -6860,11 +6860,11 @@ package body Einfo is Set_Subprograms_For_Type (Id, V); end Set_Invariant_Procedure; - ----------------------------- - -- Set_Predicate_Procedure -- - ----------------------------- + ---------------------------- + -- Set_Predicate_Function -- + ---------------------------- - procedure Set_Predicate_Procedure (Id : E; V : E) is + procedure Set_Predicate_Function (Id : E; V : E) is S : Entity_Id; begin @@ -6882,7 +6882,7 @@ package body Einfo is end loop; Set_Subprograms_For_Type (Id, V); - end Set_Predicate_Procedure; + end Set_Predicate_Function; ----------------- -- Size_Clause -- Index: einfo.ads =================================================================== --- einfo.ads (revision 165763) +++ einfo.ads (working copy) @@ -1677,7 +1677,7 @@ package Einfo is -- 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 procedure entity, to distinguish it among +-- Also set in the predicate function entity, to distinguish it among -- entries in the Subprograms_For_Type. -- Has_Primitive_Operations (Flag120) [base type only] @@ -3276,13 +3276,12 @@ package Einfo is -- Direct_Primitive_Operations of its CRT; otherwise returns No_Elist. -- For all the other types returns the Direct_Primitive_Operations. --- Predicate_Procedure (synthesized) +-- Predicate_Function (synthesized) -- Present in all types. Set for types for which (Has_Predicates is True) -- and for which a predicate procedure has been built that tests that the --- specified predicates are True. Contains the entity for the procedure --- which takes a single argument of the given type, and returns if the --- predicate holds, or raises exception Assertion_Error with an exception --- message if it does not hold. +-- specified predicates are True. Contains the entity for the function +-- which takes a single argument of the given type, and returns True if +-- the predicate holds and False if it does not. -- -- 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. @@ -3662,7 +3661,7 @@ package Einfo is -- entity. Basically this is a way of multiplexing the single field to -- hold more than one entity (since we ran out of space in some type -- entities). This is currently used for Invariant_Procedure and also --- for Predicate_Procedure, and clients will always use the latter two +-- for Predicate_Function, and clients will always use the latter two -- names to access entries in this list. -- Suppress_Elaboration_Warnings (Flag148) @@ -4832,7 +4831,7 @@ package Einfo is -- Implementation_Base_Type (synth) -- Invariant_Procedure (synth) -- Is_Access_Protected_Subprogram_Type (synth) - -- Predicate_Procedure (synth) + -- Predicate_Function (synth) -- Root_Type (synth) -- Size_Clause (synth) @@ -6824,10 +6823,10 @@ package Einfo is --------------------------------------------------- function Invariant_Procedure (Id : E) return N; - function Predicate_Procedure (Id : E) return N; + function Predicate_Function (Id : E) return N; procedure Set_Invariant_Procedure (Id : E; V : E); - procedure Set_Predicate_Procedure (Id : E; V : E); + procedure Set_Predicate_Function (Id : E; V : E); ----------------------------------- -- Field Initialization Routines -- Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 165763) +++ sem_prag.adb (working copy) @@ -11172,8 +11172,7 @@ package body Sem_Prag is -- pragma Predicate -- ([Entity =>] type_LOCAL_NAME, - -- [Check =>] EXPRESSION - -- [,[Message =>] String_Expression]); + -- [Check =>] EXPRESSION); when Pragma_Predicate => Predicate : declare Type_Id : Node_Id; @@ -11184,16 +11183,10 @@ package body Sem_Prag is begin GNAT_Pragma; - Check_At_Least_N_Arguments (2); - Check_At_Most_N_Arguments (3); + Check_Arg_Count (2); Check_Optional_Identifier (Arg1, Name_Entity); Check_Optional_Identifier (Arg2, Name_Check); - if Arg_Count = 3 then - Check_Optional_Identifier (Arg3, Name_Message); - Check_Arg_Is_Static_Expression (Arg3, Standard_String); - end if; - Check_Arg_Is_Local_Name (Arg1); Type_Id := Get_Pragma_Arg (Arg1); @@ -11206,8 +11199,10 @@ package body Sem_Prag is -- The remaining processing is simply to link the pragma on to -- the rep item chain, for processing when the type is frozen. - -- This is accomplished by a call to Rep_Item_Too_Late. + -- This is accomplished by a call to Rep_Item_Too_Late. We also + -- mark the type as having predicates. + Set_Has_Predicates (Typ); Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); end Predicate; Index: freeze.adb =================================================================== --- freeze.adb (revision 165755) +++ freeze.adb (working copy) @@ -3787,6 +3787,28 @@ package body Freeze is end if; end if; + -- If we have predicates, then this is where we build the predicate + -- function, and return the spec and body as freeze actions. + + if Has_Predicates (E) then + declare + FDecl : Node_Id; + FBody : Node_Id; + + begin + Build_Predicate_Function (E, FDecl, FBody); + + if Present (FDecl) then + if No (Result) then + Result := Empty_List; + end if; + + Append_To (Result, FDecl); + Append_To (Result, FBody); + end if; + end; + end if; + -- Generic types are never seen by the back-end, and are also not -- processed by the expander (since the expander is turned off for -- generic processing), so we never need freeze nodes for them. Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 165763) +++ exp_ch4.adb (working copy) @@ -4318,14 +4318,17 @@ package body Exp_Ch4 is procedure Expand_N_In (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Rtyp : constant Entity_Id := Etype (N); + Restyp : constant Entity_Id := Etype (N); Lop : constant Node_Id := Left_Opnd (N); Rop : constant Node_Id := Right_Opnd (N); Static : constant Boolean := Is_OK_Static_Expression (N); + Ltyp : Entity_Id; + Rtyp : Entity_Id; + procedure Expand_Set_Membership; - -- For each disjunct we create a simple equality or membership test. - -- The whole membership is rewritten as a short-circuit disjunction. + -- For each choice we create a simple equality or membership test. + -- The whole membership is rewritten connecting these with OR ELSE. --------------------------- -- Expand_Set_Membership -- @@ -4400,7 +4403,7 @@ package body Exp_Ch4 is Prefix => Relocate_Node (Lop), Attribute_Name => Name_Valid)); - Analyze_And_Resolve (N, Rtyp); + Analyze_And_Resolve (N, Restyp); Error_Msg_N ("?explicit membership test may be optimized away", N); Error_Msg_N -- CODEFIX @@ -4411,24 +4414,32 @@ package body Exp_Ch4 is -- Start of processing for Expand_N_In begin + -- If set membersip case, expand with separate procedure + if Present (Alternatives (N)) then Remove_Side_Effects (Lop); Expand_Set_Membership; return; end if; + -- Not set membership, proceed with expansion + + Ltyp := Etype (Left_Opnd (N)); + Rtyp := Etype (Right_Opnd (N)); + -- Check case of explicit test for an expression in range of its -- subtype. This is suspicious usage and we replace it with a 'Valid -- test and give a warning. For floating point types however, this is a -- standard way to check for finite numbers, and using 'Valid would -- typically be a pessimization. - if Is_Scalar_Type (Etype (Lop)) - and then not Is_Floating_Point_Type (Etype (Lop)) + if Is_Scalar_Type (Ltyp) + and then not Is_Floating_Point_Type (Ltyp) and then Nkind (Rop) in N_Has_Entity - and then Etype (Lop) = Entity (Rop) + and then Ltyp = Entity (Rop) and then Comes_From_Source (N) and then VM_Target = No_VM + and then No (Predicate_Function (Rtyp)) then Substitute_Valid_Check; return; @@ -4448,8 +4459,6 @@ package body Exp_Ch4 is Lo : constant Node_Id := Low_Bound (Rop); Hi : constant Node_Id := High_Bound (Rop); - Ltyp : constant Entity_Id := Etype (Lop); - Lo_Orig : constant Node_Id := Original_Node (Lo); Hi_Orig : constant Node_Id := Original_Node (Hi); @@ -4493,7 +4502,7 @@ package body Exp_Ch4 is and then VM_Target = No_VM then Substitute_Valid_Check; - return; + goto Leave; end if; -- If bounds of type are known at compile time, and the end points @@ -4517,7 +4526,7 @@ package body Exp_Ch4 is and then not In_Instance then Substitute_Valid_Check; - return; + goto Leave; end if; -- If we have an explicit range, do a bit of optimization based on @@ -4537,10 +4546,9 @@ package body Exp_Ch4 is end if; Rewrite (N, New_Reference_To (Standard_False, Loc)); - Analyze_And_Resolve (N, Rtyp); + Analyze_And_Resolve (N, Restyp); Set_Is_Static_Expression (N, Static); - - return; + goto Leave; -- If both checks are known to succeed, replace result by True, -- since we know we are in range. @@ -4552,10 +4560,9 @@ package body Exp_Ch4 is end if; Rewrite (N, New_Reference_To (Standard_True, Loc)); - Analyze_And_Resolve (N, Rtyp); + Analyze_And_Resolve (N, Restyp); Set_Is_Static_Expression (N, Static); - - return; + goto Leave; -- If lower bound check succeeds and upper bound check is not -- known to succeed or fail, then replace the range check with @@ -4571,9 +4578,8 @@ package body Exp_Ch4 is Make_Op_Le (Loc, Left_Opnd => Lop, Right_Opnd => High_Bound (Rop))); - Analyze_And_Resolve (N, Rtyp); - - return; + Analyze_And_Resolve (N, Restyp); + goto Leave; -- If upper bound check succeeds and lower bound check is not -- known to succeed or fail, then replace the range check with @@ -4589,9 +4595,8 @@ package body Exp_Ch4 is Make_Op_Ge (Loc, Left_Opnd => Lop, Right_Opnd => Low_Bound (Rop))); - Analyze_And_Resolve (N, Rtyp); - - return; + Analyze_And_Resolve (N, Restyp); + goto Leave; end if; -- We couldn't optimize away the range check, but there is one @@ -4632,7 +4637,7 @@ package body Exp_Ch4 is -- For all other cases of an explicit range, nothing to be done - return; + goto Leave; -- Here right operand is a subtype mark @@ -4660,7 +4665,7 @@ package body Exp_Ch4 is if Tagged_Type_Expansion then Tagged_Membership (N, SCIL_Node, New_N); Rewrite (N, New_N); - Analyze_And_Resolve (N, Rtyp); + Analyze_And_Resolve (N, Restyp); -- Update decoration of relocated node referenced by the -- SCIL node. @@ -4670,7 +4675,7 @@ package body Exp_Ch4 is end if; end if; - return; + goto Leave; -- If type is scalar type, rewrite as x in t'First .. t'Last. -- This reason we do this is that the bounds may have the wrong @@ -4689,8 +4694,8 @@ package body Exp_Ch4 is Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, Prefix => New_Reference_To (Typ, Loc)))); - Analyze_And_Resolve (N, Rtyp); - return; + Analyze_And_Resolve (N, Restyp); + goto Leave; -- Ada 2005 (AI-216): Program_Error is raised when evaluating -- a membership test if the subtype mark denotes a constrained @@ -4709,7 +4714,7 @@ package body Exp_Ch4 is -- test as False. Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - return; + goto Leave; end if; -- Here we have a non-scalar type @@ -4720,7 +4725,7 @@ package body Exp_Ch4 is if not Is_Constrained (Typ) then Rewrite (N, New_Reference_To (Standard_True, Loc)); - Analyze_And_Resolve (N, Rtyp); + Analyze_And_Resolve (N, Restyp); -- For the constrained array case, we have to check the subscripts -- for an exact match if the lengths are non-zero (the lengths @@ -4788,7 +4793,7 @@ package body Exp_Ch4 is end if; Rewrite (N, Cond); - Analyze_And_Resolve (N, Rtyp); + Analyze_And_Resolve (N, Restyp); end Check_Subscripts; -- These are the cases where constraint checks may be required, @@ -4819,10 +4824,34 @@ package body Exp_Ch4 is end if; Rewrite (N, Cond); - Analyze_And_Resolve (N, Rtyp); + Analyze_And_Resolve (N, Restyp); end if; end; end if; + + -- At this point, we have done the processing required for the basic + -- membership test, but not yet dealt with the predicate. + + <> + + -- If a predicate is present, then we do the predicate test + + if Present (Predicate_Function (Rtyp)) then + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => Make_Predicate_Call (Rtyp, Lop))); + + -- Analyze new expression, mark left operand as analyzed to + -- avoid infinite recursion adding predicate calls. + + Set_Analyzed (Left_Opnd (N)); + Analyze_And_Resolve (N, Standard_Boolean); + + -- All done, skip attempt at compile time determination of result + + return; + end if; end Expand_N_In; -------------------------------- Index: sem_eval.adb =================================================================== --- sem_eval.adb (revision 165755) +++ sem_eval.adb (working copy) @@ -2282,6 +2282,15 @@ package body Sem_Eval is return; end if; + -- Ignore if types involved have predicates + + if Present (Predicate_Function (Etype (Left))) + or else + Present (Predicate_Function (Etype (Right))) + then + return; + end if; + -- Case of right operand is a subtype name if Is_Entity_Name (Right) then Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 165763) +++ sem_ch13.adb (working copy) @@ -1008,14 +1008,14 @@ package body Sem_Ch13 is goto Continue; end; - -- Invariant and Predicate aspects generate a corresponding - -- pragma with a first argument that is the entity, and the - -- second argument is the expression. This is inserted right - -- after the declaration, to get the required pragma placement. - -- The pragma processing takes care of the required delay. + -- Invariant aspects generate a corresponding pragma with a + -- first argument that is the entity, and the second argument + -- is the expression and anthird argument with an appropriate + -- message. This is inserted right after the declaration, to + -- get the required pragma placement. The pragma processing + -- takes care of the required delay. - when Aspect_Invariant | - Aspect_Predicate => + when Aspect_Invariant => -- Construct the pragma @@ -1025,14 +1025,14 @@ package body Sem_Ch13 is New_List (Ent, Relocate_Node (Expr)), Class_Present => Class_Present (Aspect), Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + Make_Identifier (Sloc (Id), Name_Invariant)); -- Add message unless exception messages are suppressed if not Opt.Exception_Locations_Suppressed then Append_To (Pragma_Argument_Associations (Aitem), Make_Pragma_Argument_Association (Eloc, - Chars => Name_Message, + Chars => Name_Message, Expression => Make_String_Literal (Eloc, Strval => "failed invariant from " @@ -1041,10 +1041,36 @@ package body Sem_Ch13 is Set_From_Aspect_Specification (Aitem, True); - -- For Invariant and Predicate cases, insert immediately - -- after the entity declaration. We do not have to worry - -- about delay issues since the pragma processing takes - -- care of this. + -- For Invariant case, insert immediately after the entity + -- declaration. We do not have to worry about delay issues + -- since the pragma processing takes care of this. + + Insert_After (N, Aitem); + goto Continue; + + -- Predicate aspects generate a corresponding pragma with a + -- first argument that is the entity, and the second argument + -- is the expression. This is inserted immediately after the + -- declaration, to get the required pragma placement. The + -- pragma processing takes care of the required delay. + + when Aspect_Predicate => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr)), + Class_Present => Class_Present (Aspect), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Predicate)); + + Set_From_Aspect_Specification (Aitem, True); + + -- 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. Insert_After (N, Aitem); goto Continue; @@ -3730,6 +3756,291 @@ package body Sem_Ch13 is end if; end Build_Invariant_Procedure; + ------------------------------ + -- Build_Predicate_Function -- + ------------------------------ + + -- The procedure that is constructed here has the form + + -- function typPredicate (Ixxx : typ) return Boolean is + -- begin + -- return + -- exp1 and then exp2 and then ... + -- and then typ1Predicate (typ1 (Ixxx)) + -- and then typ2Predicate (typ2 (Ixxx)) + -- and then ...; + -- end typPredicate; + + -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that + -- this is the point at which these expressions get analyzed, providing the + -- required delay, and typ1, typ2, are entities from which predicates are + -- 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; + FDecl : out Node_Id; + FBody : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Typ); + Spec : Node_Id; + SId : Entity_Id; + + Expr : Node_Id; + -- This is the expression for the return statement in the function. It + -- is build by connecting the component predicates with AND THEN. + + procedure Add_Call (T : Entity_Id); + -- Includes a call statement to the predicate function for type T in + -- Expr if T has predicates and Predicate_Function (T) is non-empty. + + procedure Add_Predicates; + -- Appends expressions for any Predicate pragmas in the rep item chain + -- Typ to Expr. Note that we look only at items for this exact entity. + -- 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 + + -------------- + -- Add_Call -- + -------------- + + procedure Add_Call (T : Entity_Id) is + Exp : Node_Id; + + begin + if Present (T) + and then Present (Predicate_Function (T)) + then + Exp := + Make_Predicate_Call + (T, + Convert_To (T, + Make_Identifier (Loc, + Chars => Object_Name))); + + if No (Expr) then + Expr := Exp; + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Exp); + end if; + end if; + end Add_Call; + + -------------------- + -- Add_Predicates -- + -------------------- + + procedure Add_Predicates is + Ritem : Node_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; + + function Replace_Node (N : Node_Id) return Traverse_Result; + -- Process single node for traversal to replace type references + + procedure Replace_Type is new Traverse_Proc (Replace_Node); + -- Traverse an expression changing every occurrence of an entity + -- reference to type T with a reference to the object argument. + + ------------------ + -- Replace_Node -- + ------------------ + + function Replace_Node (N : Node_Id) return Traverse_Result is + begin + -- Case of entity name referencing the type + + if Is_Entity_Name (N) + and then Entity (N) = Typ + then + -- Replace with object + + Rewrite (N, + Make_Identifier (Loc, + Chars => Object_Name)); + + -- All done with this node + + return Skip; + + -- Not an instance of the type entity, keep going + + else + return OK; + end if; + end Replace_Node; + + begin + Ritem := First_Rep_Item (Typ); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Predicate + then + Arg1 := First (Pragma_Argument_Associations (Ritem)); + Arg2 := Next (Arg1); + + 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 reognized 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 + + if No (Expr) then + Expr := Relocate_Node (Arg2); + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Relocate_Node (Arg2)); + end if; + end if; + end if; + + Next_Rep_Item (Ritem); + end loop; + end Add_Predicates; + + -- Start of processing for Build_Predicate_Function + + begin + -- Initialize for construction of statement list + + Expr := Empty; + FDecl := Empty; + FBody := Empty; + + -- Return if already built or if type does not have predicates + + if not Has_Predicates (Typ) + or else Present (Predicate_Function (Typ)) + then + return; + end if; + + -- Add Predicates for the current type + + Add_Predicates; + + -- Deal with ancestor subtype and parent type + + declare + Atyp : constant Entity_Id := Ancestor_Subtype (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; + + -- Add predicates of any interfaces of a tagged type + + if Is_Tagged_Type (Typ) then + declare + Iface_List : Elist_Id; + Elmt : Elmt_Id; + + begin + Collect_Interfaces (Typ, Iface_List); + + if Present (Iface_List) then + loop + Elmt := First_Elmt (Iface_List); + exit when No (Elmt); + Add_Call (Node (Elmt)); + Remove_Elmt (Iface_List, Elmt); + end loop; + end if; + end; + end if; + + if Present (Expr) then + + -- Build function declaration + + pragma Assert (Has_Predicates (Typ)); + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + Set_Has_Predicates (SId); + Set_Predicate_Function (Typ, SId); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Object_Name), + 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 + + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => 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)))); + end if; + end Build_Predicate_Function; + ----------------------------------- -- Check_Constant_Address_Clause -- ----------------------------------- Index: sem_ch13.ads =================================================================== --- sem_ch13.ads (revision 165755) +++ sem_ch13.ads (working copy) @@ -57,11 +57,25 @@ package Sem_Ch13 is PDecl : out Node_Id; PBody : out Node_Id); -- If Typ has Invariants (indicated by Has_Invariants being set for Typ, - -- indicating the presence of Pragma Invariant entries on the rep chain, + -- indicating the presence of pragma Invariant entries on the rep chain, -- note that Invariant aspects are converted to pragma Invariant), then -- this procedure builds the spec and body for the corresponding Invariant - -- procedure, returning themn in PDecl and PBody. In some error situations - -- no procedure is built, in which case PDecl/PBody are empty on return. + -- procedure, returning themn in PDecl and PBody. Invariant_Procedure is + -- set for Typ. In some error situations no procedure is built, in which + -- case PDecl/PBody are empty on return. + + procedure Build_Predicate_Function + (Typ : Entity_Id; + FDecl : out Node_Id; + FBody : out Node_Id); + -- If Typ has predicates (indicated by Has_Predicates being set for Typ, + -- then either there are pragma Invariant entries on the rep chain for the + -- type (note that Predicate aspects are converted to pragam Predicate), or + -- there are inherited aspects from a parent type, or ancestor subtypes, + -- or interfaces. This procedure builds the spec and body for the Predicate + -- function that tests these predicates, returning them in PDecl and Pbody + -- and setting Predicate_Procedure for Typ. In some error situations no + -- procedure is built, in which case PDecl/PBody are empty on return. procedure Check_Record_Representation_Clause (N : Node_Id); -- This procedure completes the analysis of a record representation clause