From patchwork Wed Apr 20 10:20:03 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 612614 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.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3qqdDq2v0Hz9t3f for ; Wed, 20 Apr 2016 20:20:24 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=kM4cmvLG; dkim-atps=neutral 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=CysXg4LBphQ7cHbpxR9mDvV85Hqa3K4ZwOOcyDX86z/03oVd2k 42dbBA/p0FxNB+ILPnKbgAcmvBu3XAQSusd8O/l0ya73sBWx53S1cvHExYfXnqOI kt4z4RjH2Roem62c+8nrqkF7aLyGJBl1Tkb9wWOkKZOt045XLI5YpsHNw= 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=KgseNcTGE0KGXouMXTKPJo60POQ=; b=kM4cmvLGw3Jy9n0UKqAL /g06dVblTTjr6M3OBnOYJfOtx4EyopiN5Bbx+Jr/3UGVIOIjIogppzFQ8ZAjNfIG IV3PhUdsONzVqwCF8oVnHbZ6DIEtKnBGMZ785QnRQ7+Du4+BI034+L+bSs6VLVw5 OofZJa5ZQ2ESucmisDopnwo= Received: (qmail 106606 invoked by alias); 20 Apr 2016 10:20:16 -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 106590 invoked by uid 89); 20 Apr 2016 10:20:15 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=2.3 required=5.0 tests=AWL, BAYES_50, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY, RCVD_IN_DNSWL_NONE, T_FILL_THIS_FORM_SHORT autolearn=no version=3.3.2 spammy=nam, elsif, Nam, nkind X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Wed, 20 Apr 2016 10:20:05 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 95D0A116C7C; Wed, 20 Apr 2016 06:20:03 -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 RtXAik3bbqUo; Wed, 20 Apr 2016 06:20:03 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 80985116C79; Wed, 20 Apr 2016 06:20:03 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 7D8393ED; Wed, 20 Apr 2016 06:20:03 -0400 (EDT) Date: Wed, 20 Apr 2016 06:20:03 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Constraint_Error on spurious ambiguity in instance Message-ID: <20160420102003.GA74859@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This match modifies the processing of generics to aid overload resolution of binary and unary operators in instances. This is achieved by installing type conversions in the form of qualified expressions for each operand that yields a universal type. ------------ -- Source -- ------------ -- px.ads package PX is pragma Pure; Min_Integer : constant := -2**31; Max_Integer : constant := 2**31 - 1; subtype Integer_T is Integer range Min_Integer .. Max_Integer; subtype Natural_T is Integer_T range 0 .. Integer_T'last; subtype String_T is String; end PX; -- pg.ads with PX; generic type Element_T is (<>); type Index_T is (<>); type String_T is array (Index_T range <>) of Element_T; Blank_Element : in Element_T; package PG is function Left_Piece (Str : in String_T; Size : in PX.Natural_T; Pad_Character : in Element_T := Blank_Element) return String_T; end PG; -- pg.adb package body PG is subtype Null_String_T is String_T (Index_T'Last .. Index_T'First); Null_String : constant Null_String_T := (others => Element_T'First); function "+" (L : in PX.Integer_T; R : in Index_T ) return Index_T; function "+" (L : in Index_T; R : in PX.Integer_T) return Index_T; function "-" (L : in Index_T; R : in PX.Integer_T) return Index_T; function "+" (L : in PX.Integer_T; R : in Index_T) return Index_T is begin return Index_T'Val (L + Index_T'Pos(R)); end "+"; function "+" (L : in Index_T; R : in PX.Integer_T) return Index_T is begin return Index_T'Val (Index_T'Pos (L) + R); end "+"; function "-" (L : in Index_T; R : in PX.Integer_T) return Index_T is begin return Index_T'Val (Index_T'Pos (L) - R); end "-"; function Left_Piece (Str : in String_T; Size : in PX.Natural_T; Pad_Character : in Element_T := Blank_Element) return String_T is begin if Size > 0 then declare Result : String_T (Index_T'First .. Index_T'First + Size - 1); begin if Size < Str'Length then Result := Str (Str'First .. Str'First + Size - 1); elsif Size = Str'Length then Result := Str; else if Str'Length > 0 then Result (Result'First .. Result'First + Str'Length - 1) := Str; end if; Result (Result'First + Str'Length .. Result'Last) := (others => Pad_Character); end if; return Result; end; else return Null_String; end if; end Left_Piece; end PG; -- nullstr.adb with Ada.Text_IO; use Ada.Text_IO; with PG; procedure Nullstr is package PPG is new PG (Element_T => Character, Index_T => Positive, String_T => String, Blank_Element => '$'); begin Put_Line (PPG.Left_Piece ("abcdef", 6)); Put_Line (PPG.Left_Piece ("abcde", 6)); Put_Line (PPG.Left_Piece ("", 6)); end Nullstr; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q nullstr.adb $ ./nullstr abcdef abcde$ $$$$$$ Tested on x86_64-pc-linux-gnu, committed on trunk 2016-04-20 Hristian Kirtchev * sem_ch12.adb (Qualify_Universal_Operands): New routine. (Save_References_In_Operator): Add explicit qualifications in the generic template for all operands of universal type. * sem_type.adb (Disambiguate): Update the call to Matches. (Matches): Reimplemented. * sem_util.ads, sem_util.adb (Yields_Universal_Type): New routine. Index: sem_type.adb =================================================================== --- sem_type.adb (revision 235199) +++ sem_type.adb (working copy) @@ -1316,13 +1316,13 @@ -- the generic. Within the instance the actual is represented by a -- constructed subprogram renaming. - function Matches (Actual, Formal : Node_Id) return Boolean; - -- Look for exact type match in an instance, to remove spurious - -- ambiguities when two formal types have the same actual. + function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean; + -- Determine whether function Func_Id is an exact match for binary or + -- unary operator Op. function Operand_Type return Entity_Id; - -- Determine type of operand for an equality operation, to apply - -- Ada 2005 rules to equality on anonymous access types. + -- Determine type of operand for an equality operation, to apply Ada + -- 2005 rules to equality on anonymous access types. function Standard_Operator return Boolean; -- Check whether subprogram is predefined operator declared in Standard. @@ -1412,14 +1412,82 @@ -- Matches -- ------------- - function Matches (Actual, Formal : Node_Id) return Boolean is - T1 : constant Entity_Id := Etype (Actual); - T2 : constant Entity_Id := Etype (Formal); + function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean is + function Matching_Types + (Opnd_Typ : Entity_Id; + Formal_Typ : Entity_Id) return Boolean; + -- Determine whether operand type Opnd_Typ and formal parameter type + -- Formal_Typ are either the same or compatible. + + -------------------- + -- Matching_Types -- + -------------------- + + function Matching_Types + (Opnd_Typ : Entity_Id; + Formal_Typ : Entity_Id) return Boolean + is + begin + -- A direct match + + if Opnd_Typ = Formal_Typ then + return True; + + -- Any integer type matches universal integer + + elsif Opnd_Typ = Universal_Integer + and then Is_Integer_Type (Formal_Typ) + then + return True; + + -- Any floating point type matches universal real + + elsif Opnd_Typ = Universal_Real + and then Is_Floating_Point_Type (Formal_Typ) + then + return True; + + -- The type of the formal parameter maps a generic actual type to + -- a generic formal type. If the operand type is the type being + -- mapped in an instance, then this is a match. + + elsif Is_Generic_Actual_Type (Formal_Typ) + and then Etype (Formal_Typ) = Opnd_Typ + then + return True; + + -- ??? There are possibly other cases to consider + + else + return False; + end if; + end Matching_Types; + + -- Local variables + + F1 : constant Entity_Id := First_Formal (Func_Id); + F1_Typ : constant Entity_Id := Etype (F1); + F2 : constant Entity_Id := Next_Formal (F1); + F2_Typ : constant Entity_Id := Etype (F2); + Lop_Typ : constant Entity_Id := Etype (Left_Opnd (Op)); + Rop_Typ : constant Entity_Id := Etype (Right_Opnd (Op)); + + -- Start of processing for Matches + begin - return T1 = T2 - or else - (Is_Numeric_Type (T2) - and then (T1 = Universal_Real or else T1 = Universal_Integer)); + if Lop_Typ = F1_Typ then + return Matching_Types (Rop_Typ, F2_Typ); + + elsif Rop_Typ = F2_Typ then + return Matching_Types (Lop_Typ, F1_Typ); + + -- Otherwise this is not a good match bechause each operand-formal + -- pair is compatible only on base type basis which is not specific + -- enough. + + else + return False; + end if; end Matches; ------------------ @@ -1697,6 +1765,7 @@ It1 := It; Nam1 := It.Nam; + while I /= I2 loop Get_Next_Interp (I, It); end loop; @@ -1967,10 +2036,7 @@ end; elsif Nkind (N) in N_Binary_Op then - if Matches (Left_Opnd (N), First_Formal (Nam1)) - and then - Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1))) - then + if Matches (N, Nam1) then return It1; else return It2; Index: sem_ch12.adb =================================================================== --- sem_ch12.adb (revision 235243) +++ sem_ch12.adb (working copy) @@ -13848,6 +13848,19 @@ -- global because it is used to denote a specific compilation unit at -- the time the instantiations will be analyzed. + procedure Qualify_Universal_Operands + (Op : Node_Id; + Func_Call : Node_Id); + -- Op denotes a binary or unary operator in generic template Templ. Node + -- Func_Call is the function call alternative of the operator within the + -- the analyzed copy of the template. Change each operand which yields a + -- universal type by wrapping it into a qualified expression + -- + -- Actual_Typ'(Operand) + -- + -- where Actual_Typ is the type of corresponding actual parameter of + -- Operand in Func_Call. + procedure Reset_Entity (N : Node_Id); -- Save semantic information on global entity so that it is not resolved -- again at instantiation time. @@ -13938,6 +13951,109 @@ end if; end Is_Global; + -------------------------------- + -- Qualify_Universal_Operands -- + -------------------------------- + + procedure Qualify_Universal_Operands + (Op : Node_Id; + Func_Call : Node_Id) + is + procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id); + -- Rewrite operand Opnd as a qualified expression of the form + -- + -- Actual_Typ'(Opnd) + -- + -- where Actual is the corresponding actual parameter of Opnd in + -- function call Func_Call. + + function Qualify_Type + (Loc : Source_Ptr; + Typ : Entity_Id) return Node_Id; + -- Qualify type Typ by creating a selected component of the form + -- + -- Scope_Of_Typ.Typ + + --------------------- + -- Qualify_Operand -- + --------------------- + + procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id) is + Loc : constant Source_Ptr := Sloc (Opnd); + Typ : constant Entity_Id := Etype (Actual); + Mark : Node_Id; + + begin + -- Qualify the operand when it is of a universal type. Note that + -- the template is unanalyzed and it is not possible to directly + -- query the type. This transformation is not done when the type + -- of the actual is internally generated because the type will be + -- regenerated in the instance. + + if Yields_Universal_Type (Opnd) + and then Comes_From_Source (Typ) + and then not Is_Hidden (Typ) + then + -- The type of the actual may be a global reference. Save this + -- information by creating a reference to it. + + if Is_Global (Typ) then + Mark := New_Occurrence_Of (Typ, Loc); + + -- Otherwise rely on resolution to find the proper type within + -- the instance. + + else + Mark := Qualify_Type (Loc, Typ); + end if; + + Rewrite (Opnd, + Make_Qualified_Expression (Loc, + Subtype_Mark => Mark, + Expression => Relocate_Node (Opnd))); + end if; + end Qualify_Operand; + + ------------------ + -- Qualify_Type -- + ------------------ + + function Qualify_Type + (Loc : Source_Ptr; + Typ : Entity_Id) return Node_Id + is + Scop : constant Entity_Id := Scope (Typ); + Result : Node_Id; + + begin + Result := Make_Identifier (Loc, Chars (Typ)); + + if Present (Scop) and then Scop /= Standard_Standard then + Result := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Chars (Scop)), + Selector_Name => Result); + end if; + + return Result; + end Qualify_Type; + + -- Local variables + + Actuals : constant List_Id := Parameter_Associations (Func_Call); + + -- Start of processing for Qualify_Universal_Operands + + begin + if Nkind (Op) in N_Binary_Op then + Qualify_Operand (Left_Opnd (Op), First (Actuals)); + Qualify_Operand (Right_Opnd (Op), Next (First (Actuals))); + + elsif Nkind (Op) in N_Unary_Op then + Qualify_Operand (Right_Opnd (Op), First (Actuals)); + end if; + end Qualify_Universal_Operands; + ------------------ -- Reset_Entity -- ------------------ @@ -14716,7 +14832,8 @@ Reset_Entity (N); -- The analysis of the generic copy transformed the operator into - -- some other construct. Propagate the changes to the template. + -- some other construct. Propagate the changes to the template if + -- applicable. else N2 := Get_Associated_Node (N); @@ -14724,13 +14841,21 @@ -- The operator resoved to a function call if Nkind (N2) = N_Function_Call then + + -- Add explicit qualifications in the generic template for + -- all operands of universal type. This aids resolution by + -- preserving the actual type of a literal or an attribute + -- that yields a universal result. + + Qualify_Universal_Operands (N, N2); + E := Entity (Name (N2)); if Present (E) and then Is_Global (E) then Set_Etype (N, Etype (N2)); else Set_Associated_Node (N, Empty); - Set_Etype (N, Empty); + Set_Etype (N, Empty); end if; -- The operator was folded into a literal Index: sem_util.adb =================================================================== --- sem_util.adb (revision 235251) +++ sem_util.adb (working copy) @@ -20957,4 +20957,63 @@ end if; end Yields_Synchronized_Object; + --------------------------- + -- Yields_Universal_Type -- + --------------------------- + + function Yields_Universal_Type (N : Node_Id) return Boolean is + Nam : Name_Id; + + begin + -- Integer and real literals are of a universal type + + if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then + return True; + + -- The values of certain attributes are of a universal type + + elsif Nkind (N) = N_Attribute_Reference then + Nam := Attribute_Name (N); + + return + Nam = Name_Aft + or else Nam = Name_Alignment + or else Nam = Name_Component_Size + or else Nam = Name_Count + or else Nam = Name_Delta + or else Nam = Name_Digits + or else Nam = Name_Exponent + or else Nam = Name_First_Bit + or else Nam = Name_Fore + or else Nam = Name_Last_Bit + or else Nam = Name_Length + or else Nam = Name_Machine_Emax + or else Nam = Name_Machine_Emin + or else Nam = Name_Machine_Mantissa + or else Nam = Name_Machine_Radix + or else Nam = Name_Max_Alignment_For_Allocation + or else Nam = Name_Max_Size_In_Storage_Elements + or else Nam = Name_Model_Emin + or else Nam = Name_Model_Epsilon + or else Nam = Name_Model_Mantissa + or else Nam = Name_Model_Small + or else Nam = Name_Modulus + or else Nam = Name_Pos + or else Nam = Name_Position + or else Nam = Name_Safe_First + or else Nam = Name_Safe_Last + or else Nam = Name_Scale + or else Nam = Name_Size + or else Nam = Name_Small + or else Nam = Name_Wide_Wide_Width + or else Nam = Name_Wide_Width + or else Nam = Name_Width; + + -- ??? There are possibly other cases to consider + + else + return False; + end if; + end Yields_Universal_Type; + end Sem_Util; Index: sem_util.ads =================================================================== --- sem_util.ads (revision 235249) +++ sem_util.ads (working copy) @@ -2295,4 +2295,7 @@ -- * A synchronized interface type -- * A task type + function Yields_Universal_Type (N : Node_Id) return Boolean; + -- Determine whether unanalyzed node N yields a universal type + end Sem_Util;