From patchwork Tue Jun 22 07:03:43 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56401 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 A2DADB6F05 for ; Tue, 22 Jun 2010 17:03:54 +1000 (EST) Received: (qmail 7960 invoked by alias); 22 Jun 2010 07:03:52 -0000 Received: (qmail 7678 invoked by uid 22791); 22 Jun 2010 07:03:50 -0000 X-SWARE-Spam-Status: No, hits=-0.9 required=5.0 tests=AWL, BAYES_20, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 22 Jun 2010 07:03:42 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 6DE5FCB0231; Tue, 22 Jun 2010 09:03:43 +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 KyzGl0HGqteA; Tue, 22 Jun 2010 09:03:43 +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 564A9CB022F; Tue, 22 Jun 2010 09:03:43 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 4B884D9AB0; Tue, 22 Jun 2010 09:03:43 +0200 (CEST) Date: Tue, 22 Jun 2010 09:03:43 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Thomas Quinot Subject: [Ada] Crash on folded operator with universal operands in functional form Message-ID: <20100622070343.GA31128@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 change fixes a compiler crash that may occur when a predefined operator is called in function form with universal operands. The following compilation must be accepted quietly: pragma extend_system(Aux_DEC); with system; use system; procedure Universal_Folded_Functional_Operator is type Rec is null record; Siz : constant System.Unsigned_Longword := System."*"(Left => Rec'Size, Right => 2); begin null; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-22 Thomas Quinot * sem_eval.adb (Find_Universal_Operator_Type): New subprogram to identify the operand type of an operator on universal operands, when an explicit scope indication is present. Diagnose the case where such a call is ambiguous. (Eval_Arithmetic_Op, Eval_Relational_Op, Eval_Unary_Op): Use the above to identify the operand type so it can be properly frozen. * sem_res.adb (Make_Call_Into_Operator): Remove bogus freeze of operand type, done in an arbitrary, possibly incorrect type (the presence of some numeric type in the scope is checked for legality, but when more than one such type is in the scope, we just pick a random one, not necessarily the expected one). * sem_utils.ads, sem_utils.adb (Is_Universal_Numeric_Type): New utility subprogram. Index: sem_util.adb =================================================================== --- sem_util.adb (revision 161078) +++ sem_util.adb (working copy) @@ -7082,6 +7082,15 @@ package body Sem_Util is return (U /= 0); end Is_True; + ------------------------------- + -- Is_Universal_Numeric_Type -- + ------------------------------- + + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is + begin + return T = Universal_Integer or else T = Universal_Real; + end Is_Universal_Numeric_Type; + ------------------- -- Is_Value_Type -- ------------------- Index: sem_util.ads =================================================================== --- sem_util.ads (revision 161078) +++ sem_util.ads (working copy) @@ -800,6 +800,9 @@ package Sem_Util is -- Boolean operand (i.e. is either 0 for False, or 1 for True). This -- function simply tests if it is True (i.e. non-zero) + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean; + -- True if T is Universal_Integer or Universal_Real + function Is_Value_Type (T : Entity_Id) return Boolean; -- Returns true if type T represents a value type. This is only relevant to -- CIL, will always return false for other targets. A value type is a CIL @@ -1259,7 +1262,7 @@ package Sem_Util is -- may be a child unit with any number of ancestors. function Universal_Interpretation (Opnd : Node_Id) return Entity_Id; - -- Yields universal_Integer or Universal_Real if this is a candidate + -- Yields Universal_Integer or Universal_Real if this is a candidate function Unqualify (Expr : Node_Id) return Node_Id; -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), Index: sem_res.adb =================================================================== --- sem_res.adb (revision 161087) +++ sem_res.adb (working copy) @@ -1484,14 +1484,6 @@ package body Sem_Res is else Resolve (N, Typ); end if; - - -- For predefined operators on literals, the operation freezes - -- their type. - - if Present (Orig_Type) then - Set_Etype (Act1, Orig_Type); - Freeze_Expression (Act1); - end if; end Make_Call_Into_Operator; ------------------- Index: sem_eval.adb =================================================================== --- sem_eval.adb (revision 161132) +++ sem_eval.adb (working copy) @@ -31,6 +31,7 @@ with Elists; use Elists; with Errout; use Errout; with Eval_Fat; use Eval_Fat; with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; @@ -180,12 +181,14 @@ package body Sem_Eval is -- used for producing the result of the static evaluation of the -- logical operators - procedure Test_Ambiguous_Operator (N : Node_Id); + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; -- Check whether an arithmetic operation with universal operands which -- is a rewritten function call with an explicit scope indication is -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one -- visible numeric type declared in P and the context does not impose a -- type on the result (e.g. in the expression of a type conversion). + -- If ambiguous, emit an error and return Empty, else return the result + -- type of the operator. procedure Test_Expression_Is_Foldable (N : Node_Id; @@ -1453,6 +1456,7 @@ package body Sem_Eval is Right : constant Node_Id := Right_Opnd (N); Ltype : constant Entity_Id := Etype (Left); Rtype : constant Entity_Id := Etype (Right); + Otype : Entity_Id := Empty; Stat : Boolean; Fold : Boolean; @@ -1465,15 +1469,11 @@ package body Sem_Eval is return; end if; - if (Etype (Right) = Universal_Integer - or else - Etype (Right) = Universal_Real) - and then - (Etype (Left) = Universal_Integer - or else - Etype (Left) = Universal_Real) + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) then - Test_Ambiguous_Operator (N); + Otype := Find_Universal_Operator_Type (N); end if; -- Fold for cases where both operands are of integer type @@ -1582,9 +1582,9 @@ package body Sem_Eval is Fold_Uint (N, Result, Stat); end; - -- Cases where at least one operand is a real. We handle the cases - -- of both reals, or mixed/real integer cases (the latter happen - -- only for divide and multiply, and the result is always real). + -- Cases where at least one operand is a real. We handle the cases of + -- both reals, or mixed/real integer cases (the latter happen only for + -- divide and multiply, and the result is always real). elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then declare @@ -1627,6 +1627,14 @@ package body Sem_Eval is Fold_Ureal (N, Result, Stat); end; end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; end Eval_Arithmetic_Op; ---------------------------- @@ -2371,6 +2379,7 @@ package body Sem_Eval is end if; Fold_Uint (N, Test (Result), True); + Warn_On_Known_Condition (N); end Eval_Membership_Op; @@ -2656,6 +2665,7 @@ package body Sem_Eval is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Typ : constant Entity_Id := Etype (Left); + Otype : Entity_Id := Empty; Result : Boolean; Stat : Boolean; Fold : Boolean; @@ -2887,6 +2897,17 @@ package body Sem_Eval is Set_Is_Static_Expression (N, False); end if; + -- For operators on universal numeric types called as functions with + -- an explicit scope, determine appropriate specific numeric type, and + -- diagnose possible ambiguity. + + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- For static real type expressions, we cannot use Compile_Time_Compare -- since it worries about run-time results which are not exact. @@ -2986,6 +3007,13 @@ package body Sem_Eval is Fold_Uint (N, Test (Result), Stat); end if; + -- For the case of a folded relational operator on a specific numeric + -- type, freeze operand type now. + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; + Warn_On_Known_Condition (N); end Eval_Relational_Op; @@ -3401,6 +3429,7 @@ package body Sem_Eval is procedure Eval_Unary_Op (N : Node_Id) is Right : constant Node_Id := Right_Opnd (N); + Otype : Entity_Id := Empty; Stat : Boolean; Fold : Boolean; @@ -3417,7 +3446,7 @@ package body Sem_Eval is or else Etype (Right) = Universal_Real then - Test_Ambiguous_Operator (N); + Otype := Find_Universal_Operator_Type (N); end if; -- Fold for integer case @@ -3475,6 +3504,14 @@ package body Sem_Eval is Fold_Ureal (N, Result, Stat); end; end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; end Eval_Unary_Op; ------------------------------- @@ -4724,32 +4761,61 @@ package body Sem_Eval is end if; end Test; - ----------------------------- - -- Test_Ambiguous_Operator -- - ----------------------------- + ---------------------------------- + -- Find_Universal_Operator_Type -- + ---------------------------------- - procedure Test_Ambiguous_Operator (N : Node_Id) is + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is + PN : constant Node_Id := Parent (N); Call : constant Node_Id := Original_Node (N); Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); Is_Fix : constant Boolean := Nkind (N) in N_Binary_Op and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); - -- A mixed-mode operation in this context indicates the - -- presence of fixed-point type in the designated package. + -- A mixed-mode operation in this context indicates the presence of + -- fixed-point type in the designated package. + + Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; + -- Case where N is a relational (or membership) operator (else it is an + -- arithmetic one). + + In_Membership : constant Boolean := + Nkind (PN) in N_Membership_Test + and then + Nkind (Right_Opnd (PN)) = N_Range + and then + Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) + and then + Is_Universal_Numeric_Type + (Etype (Low_Bound (Right_Opnd (PN)))) + and then + Is_Universal_Numeric_Type + (Etype (High_Bound (Right_Opnd (PN)))); + -- Case where N is part of a membership test with a universal range E : Entity_Id; Pack : Entity_Id; - Typ1 : Entity_Id; + Typ1 : Entity_Id := Empty; Priv_E : Entity_Id; begin if Nkind (Call) /= N_Function_Call or else Nkind (Name (Call)) /= N_Expanded_Name then - return; + return Empty; - elsif Nkind (Parent (N)) = N_Type_Conversion then + -- There are two cases where the context does not imply the type of the + -- operands: either the universal expression appears in a type + -- type conversion, or we are in the case of a predefined relational + -- operator, where the context type is always Boolean. + + elsif Nkind (Parent (N)) = N_Type_Conversion + or else + Is_Relational + or else + In_Membership + then Pack := Entity (Prefix (Name (Call))); -- If the prefix is a package declared elsewhere, iterate over @@ -4773,6 +4839,7 @@ package body Sem_Eval is and then Is_Integer_Type (E) = Is_Int and then (Nkind (N) in N_Unary_Op + or else Is_Relational or else Is_Fixed_Point_Type (E) = Is_Fix) then if No (Typ1) then @@ -4786,13 +4853,16 @@ package body Sem_Eval is Error_Msg_N ("\possible interpretation (inherited)#", N); Error_Msg_Sloc := Sloc (E); Error_Msg_N ("\possible interpretation (inherited)#", N); + return Empty; end if; end if; Next_Entity (E); end loop; end if; - end Test_Ambiguous_Operator; + + return Typ1; + end Find_Universal_Operator_Type; --------------------------------- -- Test_Expression_Is_Foldable --